Reason
Simple, fast & type safe code that leverages the JavaScript & OCaml ecosystems.
' : '';
closeTag = ''
break;
default:
openTag = '<' + tagName + classAttr + '>';
closeTag = '';
}
return openTag + newInnerHtml + closeTag;
}
var trustedTraverseAndHighlight = function(searchRegex, text, node) {
return trustedTraverseAndHighlightImpl(searchRegex, text, node);
};
/**
* Leaf nodes will be considered level 999 (something absurdly high).
*/
var LEAF_LEVEL = 999;
var PAGE_LEVEL = -1;
var getDomNodeStructureLevel = function getStructureLevel(node) {
if(node.tagName === 'h0' || node.tagName === 'H0') {
return 0;
}
if(node.tagName === 'h1' || node.tagName === 'H1') {
return 1;
}
if(node.tagName === 'h2' || node.tagName === 'H2') {
return 2;
}
if(node.tagName === 'h3' || node.tagName === 'H3') {
return 3;
}
if(node.tagName === 'h4' || node.tagName === 'H4') {
return 4;
}
if(node.tagName === 'h5' || node.tagName === 'H5') {
return 5;
}
if(node.tagName === 'h6' || node.tagName === 'H6') {
return 6;
}
return LEAF_LEVEL;
};
var deepensContext = function(treeNode) {
return treeNode.level >= 0 && treeNode.level < 7;
};
/**
* Searches up in the context for the correct place for this level to be
* inserted.
*/
function recontext(context, nextTreeNode) {
// Root document level is level zero.
while(context.length > 1 && context[context.length - 1].level >= nextTreeNode.level) {
context.pop();
}
};
function hierarchicalIndexForSearch(pageState) {
for(var pageKey in pageState) {
if(!pageState[pageKey].hierarchicalIndex) {
var containerNode = pageState[pageKey].contentContainerNode;
pageState[pageKey].hierarchicalIndex = hierarchicalIndexFromHierarchicalDoc(pageState[pageKey].hierarchicalDoc);
}
}
}
function mapHierarchyOne(f, treeNode) {
return {
levelContent: f(treeNode.levelContent),
level: treeNode.level,
subtreeNodes: mapHierarchy(f, treeNode.subtreeNodes)
};
}
function mapHierarchy(f, treeNodes) {
return treeNodes.map(mapHierarchyOne.bind(null, f));
}
function forEachHierarchyOne(f, context, treeNode) {
var newContext = updateContextFromTreeNode(context, treeNode);
f(treeNode.levelContent, treeNode.level, treeNode.subtreeNodes, newContext);
forEachHierarchyImpl(f, newContext, treeNode.subtreeNodes);
}
function forEachHierarchyImpl(f, context, treeNodes) {
return treeNodes.forEach(forEachHierarchyOne.bind(null, f, context));
}
function forEachHierarchy(f, treeNodes) {
var context = startContext;
return treeNodes.forEach(forEachHierarchyOne.bind(null, f, context));
}
/**
* Returns a hierarchy tree where level contents are the individual items that
* may be searchable. The original structured hierarchy tree has the
* levelContent of each subtreeNode being the root node of every element that
* appears directly under that heading. The hierarchicalIndex expands a single
* tree node (such as one for a ul element) into several tree nodes (one for
* each li in the ul for example). So it's a pretty simple mapping of the tree,
* where each levelContent is expanded out into an array of content.
*/
function hierarchicalIndexFromHierarchicalDoc(treeNodes) {
function expandTreeNodeContentToSearchables(domNode) {
if(isNodeSearchHit(domNode)) {
return [domNode];
} else {
var more = [];
var childDomNode = domNode.firstChild;
while(childDomNode) {
more = more.concat(expandTreeNodeContentToSearchables(childDomNode));
childDomNode = childDomNode.nextSibling;
}
return more;
}
};
return treeNodes.map(mapHierarchyOne.bind(null, expandTreeNodeContentToSearchables));
}
/**
* Forms a hierarchy of content from structure forming nodes (such as headers)
* from what would otherwise be a flat document.
* The subtreeNodes are not dom Subtree nodes but the hierarchy subtree (level
* heading content etc).
*
* The subtreeNodes are either the list of Dom nodes immediately under that
* level, else another "tree" node. (Type check it at runtime by looking for
* .tagName property).
*
* page:
*
* H1Text
* text
* H2Text
* textB
* textC
*
* Would be of the shape:
* {
* level: 0, // page
* levelContent: null,
* subtreeNodes: [
* {
* level: 1,
* levelContent: H1Text
, // h1 dom node
* subtreeNodes: [
* {level: LEAF_LEVEL, levelContent: text
}, // p DOM node
* {
* level: 2,
* levelContent: H2Text
,
* subtreeNodes: [
* {level: LEAF_LEVEL, levelContent: textB
},
* {level: LEAF_LEVEL, levelContent: textC
}
* ]
* }
* ]
*
* }
*
* ]
* }
*/
function hierarchize(containerNode) {
// Mutable reference.
var dummyNode = {
// Such as the h2 node that forms the new level etc.
levelContent: null,
level: PAGE_LEVEL,
subtreeNodes: []
};
var context = [dummyNode];
function hierarchicalIndexChildrenImpl(domNode) {
var childDomNode = domNode.firstChild;
while(childDomNode) {
hierarchicalIndexImpl(childDomNode);
childDomNode = childDomNode.nextSibling;
}
};
function hierarchicalIndexImpl(domNode) {
var domNodeLevel = getDomNodeStructureLevel(domNode);
var treeNode = {
levelContent: domNode,
level: domNodeLevel,
subtreeNodes: []
};
recontext(context, treeNode);
context[context.length - 1].subtreeNodes.push(treeNode);
if(deepensContext(treeNode)) {
context.push(treeNode)
}
};
hierarchicalIndexChildrenImpl(containerNode);
return dummyNode.subtreeNodes;
};
var filterHierarchicalSearchablesLowerCaseImpl = function(searchRegex, txt, pageState, renderTopRow) {
var totalResultsLen = function() {
return smartCaseWordBoundaryResults.length +
smartCaseAnywhereNotWordBoundaryResults.length +
caseInsensitiveWordBoundaryResults.length +
caseInsensitiveAnywhereNotWordBoundaryResults.length;
};
var smartCaseWordBoundaryResults = [];
var smartCaseAnywhereNotWordBoundaryResults = [];
var caseInsensitiveWordBoundaryResults = [];
var caseInsensitiveAnywhereNotWordBoundaryResults = [];
// On the first keystroke, it will return far too many results, almost all of
// them useless since it matches anything with that character. In that case, limit to
// 20 results. Then on the next keystroke allow more.
var maxResultsLen = txt.length === 1 ? 20 : 999;
Flatdoc.forEachPage(pageState, (pageData, pageKey) => {
forEachSearchableInHierarchy(function(searchable) {
if(totalResultsLen() < maxResultsLen) {
var node = searchable.node;
var context = searchable.context;
var nodeText = node.nodeType === Node.TEXT_NODE ? node.textContent : node.innerText;
var test = findBestMatch(nodeText, searchRegex);
var resultsToPush =
test === -1 ? null :
test & (SMARTCASE | WORDBOUNDARY) ? smartCaseWordBoundaryResults :
test & (SMARTCASE) ? smartCaseAnywhereNotWordBoundaryResults :
test & (WORDBOUNDARY) ? caseInsensitiveAnywhereNotWordBoundaryResults :
caseInsensitiveAnywhereNotWordBoundaryResults;
if(resultsToPush !== null) {
// TODO: Show multiple matches per searchable.
resultsToPush.push({
searchable: searchable,
highlightedInnerText: trustedTraverseAndHighlight(searchRegex, txt, node),
topRow: renderTopRow(searchable.context, node)
})
}
}
}, pageData.hierarchicalIndex);
});
return smartCaseWordBoundaryResults.concat(
smartCaseAnywhereNotWordBoundaryResults
).concat(
caseInsensitiveWordBoundaryResults)
.concat(
caseInsensitiveAnywhereNotWordBoundaryResults
)
};
/**
* Invokes the callback for each searchable tree node (which has expanded array
* of levelContent), will not invoke callback for subtree of that searchable
* node, even if they are searchable.
*/
function forEachSearchableInHierarchyImpl(cb, treeNode, context) {
for(var j = 0; j < treeNode.levelContent.length; j++) {
var searchable = {node: treeNode.levelContent[j], context: context};
cb(searchable);
}
context = updateContextFromTreeNode(context, treeNode);
forEachSearchableInHierarchy(cb, treeNode.subtreeNodes, context);
}
function forEachSearchableInHierarchy(cb, treeNodes, context) {
var context = typeof context === 'undefined' ? startContext : context;
for(var i = 0; i < treeNodes.length; i++) {
forEachSearchableInHierarchyImpl(cb, treeNodes[i], context);
}
}
/**
* Useful for converting unfiltered results into a "filtered" "highlighted" results set.
*/
var noopHierarchicalFilter = function(pageState, renderTopRow) {
var results = [];
// TODO: Here is where you would categorize the results by page.
Flatdoc.forEachPage(pageState, (pageData, pageKey) => {
forEachSearchableInHierarchy(function(searchable) {
results.push({
searchable: searchable,
highlightedInnerText: trustedTraverseAndHighlight(null, "", searchable.node),
topRow: renderTopRow(searchable.context, searchable.node)
});
}, pageData.hierarchicalIndex);
});
return results;
};
var SMARTCASE = 0b10;
var WORDBOUNDARY = 0b01;
var regexesFor = function(str) {
var hasUpper = str.toLowerCase() !== str;
return {
// TODO: Add checks that remove symbols like hyphen, dot, parens
smartCase: {
// Priority 1
wordBoundary: !hasUpper ? null : new RegExp('\\b(' + escapeRegExpSplitString(str) + ')', 'g' + (hasUpper ? '' : 'i')),
// Priority 2
anywhere: !hasUpper ? null : new RegExp('(' + escapeRegExpSplitString(str) + ')', 'g' + (hasUpper ? '' : 'i'))
},
caseInsensitive: {
// Priority 3
wordBoundary: new RegExp('\\b(' + escapeRegExpSplitString(str) + ')', 'gi'),
// Priority 4
anywhere: new RegExp('(' + escapeRegExpSplitString(str) + ')', 'gi')
}
}
};
var findBestMatch = function(stringToTest, regexes) {
if(regexes.smartCase.wordBoundary && regexes.smartCase.wordBoundary.test(stringToTest)) {
return SMARTCASE | WORDBOUNDARY;
} else if(regexes.smartCase.anywhere && regexes.smartCase.anywhere.test(stringToTest)) {
return SMARTCASE;
} else if(regexes.caseInsensitive.wordBoundary.test(stringToTest)) {
return WORDBOUNDARY;
} else if (regexes.caseInsensitive.anywhere.test(stringToTest)) {
return 0
} else {
return -1;
}
};
var filterHierarchicalSearchables = function(query, pageState, renderTopRow) {
var txt = query.trim();
var searchRegex = regexesFor(txt);new RegExp('(' + escapeRegExpSplitString(txt) + ')', 'gi');
return filterHierarchicalSearchablesLowerCaseImpl(searchRegex, txt, pageState, renderTopRow);
};
var matchedSearchableToHit = function(matchedSearchable) {
return {
category:
matchedSearchable.searchable.context.h3 ? matchedSearchable.searchable.context.h3.innerText :
matchedSearchable.searchable.context.h2 ? matchedSearchable.searchable.context.h2.innerText :
matchedSearchable.searchable.context.h1 ? matchedSearchable.searchable.context.h1.innerText : "",
content: matchedSearchable.searchable.node.innerText,
matchedSearchable: matchedSearchable
}
};
/* Matches found in the header itself will be considered in that context */
var startContext = {
h0: null,
h1: null,
h2: null,
h3: null,
h4: null,
h5: null,
h6: null
};
var contextToSlug = function(context, slugContributions) {
var slug = '';
if(context.h0 && slugContributions.h0) {
slug += ' ' + Flatdoc.slugify(context.h0.levelContent.innerText);
}
if(context.h1 && slugContributions.h1) {
slug += ' ' + Flatdoc.slugify(context.h1.levelContent.innerText);
}
if(context.h2 && slugContributions.h2) {
slug += ' ' + Flatdoc.slugify(context.h2.levelContent.innerText);
}
if(context.h3 && slugContributions.h3) {
slug += ' ' + Flatdoc.slugify(context.h3.levelContent.innerText);
}
if(context.h4 && slugContributions.h4) {
slug += ' ' + Flatdoc.slugify(context.h4.levelContent.innerText);
}
if(context.h5 && slugContributions.h5) {
slug += ' ' + Flatdoc.slugify(context.h5.levelContent.innerText);
}
if(context.h6 && slugContributions.h6) {
slug += ' ' + Flatdoc.slugify(context.h6.levelContent.innerText);
}
return Flatdoc.slugify(slug.length > 0 ? slug.substring(1) : '');
};
/**
* Bookmark is just a paired down version of Flatdoc with some additional
* features, and many features removed.
*
* This version of flatdoc can run in three modes:
*
* Main entrypoint script include (when included from an index.html or
* foo.html).
*
*
*
* Included in a name.md.html markdown document or name.styl.html Stylus
* document at the start of file
*
*
* # Rest of markdown here
* - regular markdown
* - regular markdown
*
* or:
*
*
* Rest of .styl document here:
*
* As a node script which will bundle your page into a single file assuming you've run npm install.
*/
/**
* Since we use one simple script for everything, we need to detect how it's
* being used. If not a node script, it could be included form the main html
* page, or from a docs/stylus page. The main script tag in the main page will
* be run at a point where there's no body in the document. For doc pages
* (markdown/stylus) it will have a script tag at the top which implicitly
* defines a body.
*/
function detectDocOrStyleIfNotNodeScript() {
var hasParentFrame = window.parent !== window;
var hasBody = document.body !== null;
return hasParentFrame || hasBody;
};
/**
* Assuming you are a doc or a style file (in an html extension), is this
* trying to be loaded as an async doc/style content fetch from another HTML
* page, or is this file attempting to be loaded as the main entrypoint (wihout
* going through an index.html or something?) All requests for doc content go
* through the Bookmark loader, and will ensure there is a query param
* indicating this.
*/
function detectMode() {
if(typeof process !== 'undefined') {
return 'bookmarkNodeMode';
}
if(detectDocOrStyleIfNotNodeScript()) {
var isHostPageQueryingContent = queryParam('bookmarkContentQuery');
if (isHostPageQueryingContent) {
return 'bookmarkContentQuery';
} else {
return 'bookmarkEntrypoint';
}
}
// Either loading from a non template index.dev.html, or we are running a
// template that includes the Bookmark.js script. We are loading from a
// previous bookmarkEntrypoint flow, which has been turned into
// bookmarkLoadFromHostPage after injecting the template.
return 'bookmarkLoadFromHostPage';
};
var MODE = detectMode();
/**
* Here's the order of events that occur when using the local file system at least:
* 1. body DOMContentLoaded
* 2. body onload event
* 3. settimeout 0 handler.
*/
if(MODE === 'bookmarkNodeMode') {
if(process.argv && process.argv.length > 2 && process.argv[2] === 'bundle') {
var fs = require('fs');
var path = require('path');
var Inliner = require('inliner');
var siteDir = __dirname;
var pathToChrome =
process.platform === 'win32' ?
path.join(require('process').env['LOCALAPPDATA'], 'Google', 'Chrome', 'Application', 'chrome.exe') :
'/Applications/Google\\ Chrome.app/Contents/MacOS/Google\\ Chrome';
var cmd = pathToChrome + " " + path.join(siteDir, "..", "README.html") + ' --headless --dump-dom --virtual-time-budget=400';
var rendered = require('child_process').execSync(cmd).toString();
var renderedHtmlPath = path.join(siteDir, "..", 'index.rendered.html');
var indexHtmlPath = path.join(siteDir, "..", 'index.html');
fs.writeFileSync(renderedHtmlPath, rendered);
console.log("INLINING PAGE: ", indexHtmlPath);
var options = {
/* Make sure you have this set to true to avoid flickering jumps */
images: true,
compressCSS: true,
compressJS: true,
// If true, will mess with hljs.
collapseWhitespace: false,
nosvg: true, // by default, DO compress SVG with SVGO
skipAbsoluteUrls: false,
preserveComments: false,
iesafe: false
};
new Inliner(renderedHtmlPath, options, function (error, html) {
// compressed and inlined HTML page
// console.log(html);
if(error) {
console.error(e);
process.exit(1);
}
fs.writeFileSync(indexHtmlPath, html)
process.exit(0);
});
}
}
else if(MODE === 'bookmarkContentQuery') {
// We are being asked about the document content from some host page (like an index.html that
// manually calls out to docs).
document.write('');
document.addEventListener("DOMContentLoaded", function() {
var plaintexts = document.querySelectorAll('plaintext');
if(plaintexts.length === 1) {
window.parent.postMessage({
messageType: 'docPageContent' ,
iframeName: window.name,
// innerHtml escapes markup in plaintext in Safari, but not Chrome.
// innerText behaves correctly for both.
content: plaintexts[0].innerText
}, "*");
} else {
window.parent.postMessage({
messageType: "docPageError",
iframeName: window.name,
error: "There isn't exactly one plaintext tag inside of " + window.name +
". Something went wrong and we didn't inject the plaintext tag."
}, "*");
}
});
} else if(MODE === 'bookmarkEntrypoint') {
// This is the a workflow where the md html page itself wants to be loadable without
// needing to be included via some index.html. In this mode it can specify a page template
// in its markdown header.
// Remove the typical leading content before the script: This just helps
// minimize the flash of that text. To completely eliminate it during
// development mode, you can put this at the top of your md.
// [ vim: set filetype=Markdown: ]: # (<style type="text/css">body {visibility: hidden} </style>)
// while(document.body.hasChildNodes) {
while(document.body.childNodes[0].nodeType === document.TEXT_NODE) {
document.body.removeChild(document.body.childNodes[0]);
}
// Try to hide the plain text that comes before the important script include.
// Minimize flash.
document.write('<plaintext style="display:none">');
// I find page reloads much less reliable if you document.close()
// document.close();
// However, I think this caused html contents inside of the markdown to be executed as html?
window.onbeforeunload = function() {
};
document.addEventListener("DOMContentLoaded", function() {
var plaintexts = document.querySelectorAll('plaintext');
if(plaintexts.length === 1) {
// innerHtml escapes markup in plaintext in Safari, but not Chrome.
// innerText behaves correctly for both.
// Parse out the yaml header just so we can get the siteTemplate, then
// forward along the original markdown. Might as well leave the yaml
// lines normalized.
var markdown = normalizeMarkdownResponse(plaintexts[0].innerText);
var markdownNormalizedYaml = normalizeYamlMarkdownComments(markdown);
var markdownAndHeader = parseYamlHeader(markdownNormalizedYaml, window.location.pathname);
if(typeof window.BookmarkTemplate === 'undefined') {
window.BookmarkTemplate = {};
}
window.BookmarkTemplate.prefetchedCurrentPageBasename = urlBasename(window.location.href);
window.BookmarkTemplate.prefetchedCurrentPageMarkdownAndHeader = markdownNormalizedYaml;
// Set the variables for templates to read from.
// https://www.geeksforgeeks.org/how-to-replace-the-entire-html-node-using-javascript/
if(markdownAndHeader.headerProps.siteTemplate) {
var templateFetchStart = Date.now();
/**
* The iframe's onDone will fire before the document's readystatechange 'complete' event.
*/
var onDone = function(siteTemplate) {
var templateFetchEnd = Date.now();
console.log("fetching SITE TEMPLATE took", templateFetchEnd - templateFetchStart);
var yetAnotherHtml = document.open("text/html", "replace");
// If you want to listen for another readystatechange 'complete'
// after images have loaded you have to create yetAnotherHtml This
// isn't really needed since we don't listen to this. Make sure to
// hide the content while it is loading, since .write replaces.
// flatdoc:ready will reveal it after images load.
siteTemplate =
siteTemplate.replace(
new RegExp("(" +
escapeRegExpSearchString( "<template>") +
"|" + escapeRegExpSearchString( "</template>") +
"|" + escapeRegExpSearchString( "<plaintext>") +
")", "g"),
function(_) {return "";}
);
siteTemplate =
siteTemplate.replace(
new RegExp("\\$\\{Bookmark\\.Header\\.([^:\\}]*)}", 'g'),
function(matchString, field) {
if(field !== 'siteTemplate' && field in markdownAndHeader.headerProps) {
return escapeHtml(markdownAndHeader.headerProps[field]);
}
}
);
siteTemplate =
siteTemplate.replace(
new RegExp("\\$\\{Bookmark\\.Active\\.([^\\}]*)}", 'g'),
function(matchString, field) {
return markdownAndHeader.headerProps.id === field ? 'active' : 'inactive';
}
);
// The site template should also have
// <script>
// document.body.style="visibility:hidden"
// </script>
// So that when pre-rendered it is also correctly hidden
yetAnotherHtml.write(siteTemplate);
yetAnotherHtml.close();
};
var onDoneCell = {contents: onDone};
var onFailCell = {contents: (err) => {console.error(err);}};
queryContentsViaIframe(markdownAndHeader.headerProps.siteTemplate, onDoneCell, onFailCell);
} else {
console.error(
'You are loading a Bookmark doc from a markdown file, but that ' +
'markdown doc does not specify a siteTemplate: in its yaml header.'
);
}
} else {
console.error(
"There isn't exactly one plaintext tag inside of " + window.name +
". Something went wrong and we didn't inject the plaintext tag."
);
}
});
} else {
// Must be 'bookmarkLoadFromHostPage' mode. At least populate this empty
// dictionary so that when
// BookmarkTemplate.prefetchedCurrentPageMarkdownAndHeader is accessed in
// the rehydration workflow it doesn't fail (it will bail out) when it
// realizes the page is already rendered though.
if(typeof window.BookmarkTemplate === 'undefined') {
window.BookmarkTemplate = {};
}
(function($) {
var exports = this;
$.highlightNode = function(node) {
$('.bookmark-in-doc-highlight').each(function() {
var $el = $(this);
$el.removeClass('bookmark-in-doc-highlight');
});
$(node).addClass('bookmark-in-doc-highlight');
};
var marked;
/**
* Basic Flatdoc module.
*
* The main entry point is Flatdoc.run(), which invokes the [Runner].
*
* Flatdoc.run({
* fetcher: Flatdoc.github('rstacruz/backbone-patterns');
* });
*
* These fetcher functions are available:
*
* Flatdoc.github('owner/repo')
* Flatdoc.github('owner/repo', 'API.md')
* Flatdoc.github('owner/repo', 'API.md', 'branch')
* Flatdoc.bitbucket('owner/repo')
* Flatdoc.bitbucket('owner/repo', 'API.md')
* Flatdoc.bitbucket('owner/repo', 'API.md', 'branch')
* Flatdoc.file('http://path/to/url')
* Flatdoc.file([ 'http://path/to/url', ... ])
*/
var Flatdoc = exports.Flatdoc = {};
exports.Bookmark = exports.Flatdoc;
/**
* Creates a runner.
* See [Flatdoc].
*/
Flatdoc.run = function(options) {
var runner = new Flatdoc.runner(options)
runner.run();
return runner;
};
Flatdoc.mapPages = function(dict, onPage) {
var result = {};
for(var pageKey in dict) {
result[pageKey] = onPage(dict[pageKey], pageKey);
}
return result;
};
Flatdoc.forEachPage = function(dict, onPage) {
var _throwAway = Flatdoc.mapPages(
dict,
(pageData, pageKey) =>
(onPage(pageData, pageKey), pageData)
);
};
Flatdoc.keepOnly = function(dict, f) {
var result = {};
for(var pageKey in dict) {
if(f(dict[pageKey]), pageKey) {
result[pageKey] = dict[pageKey];
}
}
return result;
};
Flatdoc.setFetcher = function(keyLowerCase, obj) {
if(BookmarkTemplate.prefetchedCurrentPageBasename &&
urlExtensionlessBasename(BookmarkTemplate.prefetchedCurrentPageBasename).toLowerCase() === keyLowerCase) {
obj.fetcher = Bookmark.docPageContent(BookmarkTemplate.prefetchedCurrentPageMarkdownAndHeader);
} else {
obj.fetcher = Bookmark.docPage(keyLowerCase + ".html");
}
};
/**
* Simplified easy to use API that calls the underlying API.
*/
Flatdoc.go = function(options) {
var pageState = {};
var actualOptions = {
searchFormId: options.searchFormId,
searchHitsId: options.searchHitsId,
versionButtonId: options.versionButtonId,
versionPageIs: options.versionPageIs ? options.versionPageIs.toLowerCase() : null,
searchBreadcrumbContext: options.searchBreadcrumbContext,
slugify: options.slugify || defaultSlugifyConfig,
slugContributions: options.slugContributions || defaultSlugContributions,
sidenavify: options.sidenavify || defaultSidenavifyConfig,
pageState: pageState,
effectiveHref: ''
};
if(options.stylus) {
actualOptions.stylusFetcher = Flatdoc.docPage(options.stylus);
}
if(!options.pages) {
alert("Error, no pages provided in Bookmark options");
console.error("Error, no pages provided in Bookmark options");
} else {
var pages = options.pages;
for(var pageKey in pages) {
var pageKeyLowerCase = pageKey.toLowerCase();
var page = pages[pageKey];
pageState[pageKeyLowerCase] = {
fetcher: null,
markdownAndHeader: null,
contentContainerNode: null,
menuContainerNode: null,
hierarchicalDoc: null,
hierarchicalIndex: null
};
Flatdoc.setFetcher(pageKeyLowerCase, pageState[pageKeyLowerCase]);
}
if(options.highlight) {
actualOptions.highlight = options.highlight;
}
var runner = Flatdoc.run(actualOptions);
}
};
/**
* File fetcher function.
*
* Fetches a given url via AJAX.
* See [Runner#run()] for a description of fetcher functions.
*/
Flatdoc.file = function(url) {
function loadData(locations, response, callback) {
if (locations.length === 0) callback(null, response);
else $.get(locations.shift())
.fail(function(e) {
callback(e, null);
})
.done(function (data) {
if (response.length > 0) response += '\n\n';
response += data;
loadData(locations, response, callback);
});
}
return function(callback) {
loadData(url instanceof Array ?
url : [url], '', callback);
};
};
/**
* Runs with the already loaded string contents representing a doc.
* This is used for "entrypoint mode".
* TODO: Instead just maintain a cache, warm it up and use the regular
* fetcher. This also allows reuse as a "style pre-fetch" property in the
* yaml header.
*/
Flatdoc.docPageContent = function(url) {
if (!Flatdoc.errorHandler) {
var listenerID = window.addEventListener('message', function(e) {
if (e.data.messageType === 'docPageError') {
console.error(e.data.error);
}
});
Flatdoc.docPageErrorHandler = listenerID;
}
var fetchdocPage = function(content) {
var onDone = null;
var onFail = null;
var returns = {
fail: function(cb) {
onFail = cb;
return returns;
},
done: function(cb) {
onDone = cb;
onDone(content);
return returns;
}
};
return returns;
};
function loadData(locations, response, callback) {
if (locations.length === 0) callback(null, response);
else fetchdocPage(locations.shift())
.fail(function(e) {
callback(e, null);
})
.done(function (data) {
if (response.length > 0) response += '\n\n';
response += data;
loadData(locations, response, callback);
});
}
var url = url instanceof Array ? url : [url];
var ret = function(callback) {
loadData(url, '', callback);
};
// Tag the fetcher with the url in case you want it.
ret.url = url;
return ret;
};
/**
* Local docPage doc fetcher function.
*
* Fetches a given url via iframe inclusion, expecting the file to be of
* the "docPage" form of markdown which can be loaded offline.
* See [Runner#run()] for a description of fetcher functions.
*
* Tags the url argument on the fetcher itself so it can be used for other
* debugging/relativization.
*/
Flatdoc.docPageErrorHandler = null;
Flatdoc.docPage = function(url) {
if (!Flatdoc.errorHandler) {
var listenerID = window.addEventListener('message', function(e) {
if (e.data.messageType === 'docPageError') {
console.error(e.data.error);
}
});
Flatdoc.docPageErrorHandler = listenerID;
}
var fetchdocPage = function(url) {
var onDoneCell = {contents: null};
var onFailCell = {contents: null};
var returns = {
fail: function(cb) {
onFailCell.contents = cb;
return returns;
},
done: function(cb) {
onDoneCell.contents = cb;
return returns;
}
};
queryContentsViaIframe(url, onDoneCell, onFailCell);
// Even if using the local file system, this will immediately resume
// after appending without waiting or blocking. There is no way to tell
// that an iframe has loaded successfully without some kind of a timeout.
// Even bad src locations will fire the onload event. An onerror event is
// a solid signal that the page failed, but abscense of an onerror on the
// iframe is not a confirmation of success or that it hasn't failed.
return returns;
};
function loadData(locations, response, callback) {
if (locations.length === 0) callback(null, response);
else fetchdocPage(locations.shift())
.fail(function(e) {
callback(e, null);
})
.done(function (data) {
if (response.length > 0) response += '\n\n';
response += data;
loadData(locations, response, callback);
});
}
var url = url instanceof Array ? url : [url];
var ret = function(callback) {
loadData(url, '', callback);
};
// Tag the fetcher with the url in case you want it.
ret.url = url;
return ret;
};
/**
* Github fetcher.
* Fetches from repo repo (in format 'user/repo').
*
* If the parameter filepath` is supplied, it fetches the contents of that
* given file in the repo's default branch. To fetch the contents of
* `filepath` from a different branch, the parameter `ref` should be
* supplied with the target branch name.
*
* See [Runner#run()] for a description of fetcher functions.
*
* See: http://developer.github.com/v3/repos/contents/
*/
Flatdoc.github = function(opts) {
if (typeof opts === 'string') {
opts = {
repo: arguments[0],
filepath: arguments[1]
};
}
var url;
if (opts.filepath) {
url = 'https://api.github.com/repos/'+opts.repo+'/contents/'+opts.filepath;
} else {
url = 'https://api.github.com/repos/'+opts.repo+'/readme';
}
var data = {};
if (opts.token) {
data.access_token = opts.token;
}
if (opts.ref) {
data.ref = opts.ref;
}
return function(callback) {
$.get(url, data)
.fail(function(e) { callback(e, null); })
.done(function(data) {
var markdown = exports.Base64.decode(data.content);
callback(null, markdown);
});
};
};
/**
* Bitbucket fetcher.
* Fetches from repo `repo` (in format 'user/repo').
*
* If the parameter `filepath` is supplied, it fetches the contents of that
* given file in the repo.
*
* See [Runner#run()] for a description of fetcher functions.
*
* See: https://confluence.atlassian.com/display/BITBUCKET/src+Resources#srcResources-GETrawcontentofanindividualfile
* See: http://ben.onfabrik.com/posts/embed-bitbucket-source-code-on-your-website
* Bitbucket appears to have stricter restrictions on
* Access-Control-Allow-Origin, and so the method here is a bit
* more complicated than for Github
*
* If you don't pass a branch name, then 'default' for Hg repos is assumed
* For git, you should pass 'master'. In both cases, you should also be able
* to pass in a revision number here -- in Mercurial, this also includes
* things like 'tip' or the repo-local integer revision number
* Default to Mercurial because Git users historically tend to use GitHub
*/
Flatdoc.bitbucket = function(opts) {
if (typeof opts === 'string') {
opts = {
repo: arguments[0],
filepath: arguments[1],
branch: arguments[2]
};
}
if (!opts.filepath) opts.filepath = 'readme.md';
if (!opts.branch) opts.branch = 'default';
var url = 'https://bitbucket.org/api/1.0/repositories/'+opts.repo+'/src/'+opts.branch+'/'+opts.filepath;
return function(callback) {
$.ajax({
url: url,
dataType: 'jsonp',
error: function(xhr, status, error) {
alert(error);
},
success: function(response) {
var markdown = response.data;
callback(null, markdown);
}
});
};
};
/**
* Parser module.
* Parses a given Markdown document and returns a JSON object with data
* on the Markdown document.
*
* var data = Flatdoc.parser.parse('markdown source here');
* console.log(data);
*
* data == {
* title: 'My Project',
* content: '<p>This project is a...',
* menu: {...}
* }
*/
var Parser = Flatdoc.parser = {};
/**
* Parses a given Markdown document.
* See `Parser` for more info.
*/
Parser.parse = function(doc, markdownAndHeader, highlight, pageState, pageKey) {
marked = exports.marked;
Parser.setMarkedOptions(highlight);
var html = $("<div>" + marked(markdownAndHeader.markdown));
var title = markdownAndHeader.headerProps.title;
if(!title) {
title = html.find('h1').eq(0).text();
}
// Mangle content
Transformer.mangle(doc, html, pageState, pageKey);
var menu = Transformer.getMenu(doc, html);
return {content: html, menu: menu};
};
Parser.setMarkedOptions = function(highlight) {
marked.setOptions({
highlight: function(code, lang) {
if (lang) {
return highlight(code, lang);
}
return code;
}
});
marked.Renderer.prototype.paragraph = (text) => {
if (text.startsWith("<codetabscontainer")) {
return text + "\n";
}
return "<p>" + text + "</p>";
};
};
/**
* Transformer module.
* This takes care of any HTML mangling needed. The main entry point is
* `.mangle()` which applies all transformations needed.
*
* var $content = $("<p>Hello there, this is a docu...");
* Flatdoc.transformer.mangle($content);
*
* If you would like to change any of the transformations, decorate any of
* the functions in `Flatdoc.transformer`.
*/
var Transformer = Flatdoc.transformer = {};
/**
* Takes a given HTML `$content` and improves the markup of it by executing
* the transformations.
*
* > See: [Transformer](#transformer)
*/
Transformer.mangle = function(runner, pageKey, hierarchicalDoc) {
};
/**
* Adds IDs to headings. What's nice about this approach is that it is
* agnostic to how the markup is rendered.
* TODO: These (better) links won't always work in markdown on github because
* github doesn't encode subsections into the links. To address this, we can allow
* Github links in the markdown and then transform them into the better ones
* on the rendered page. This produces more stable linked slugs.
*/
Transformer.addIDsToHierarchicalDoc = function(runner, hierarchicalDoc, pageKey) {
var seenSlugs = {};
// Requesting side-nav requires linkifying
var headers = 'h0 h1 h2 h3 h4 h5 h6 H0 H1 H2 H3 H4 H5 H6';
forEachHierarchy(function(levelContent, level, subtreeNodes, inclusiveContext) {
if(headers.indexOf(levelContent.tagName) !== -1) {
var slugCandidate = contextToSlug(inclusiveContext, runner.slugContributions);
var slug = seenSlugs[slugCandidate] ? (slugCandidate + '--' + (seenSlugs[slugCandidate] + 1)) : slugCandidate;
seenSlugs[slugCandidate] = seenSlugs[slugCandidate] ? seenSlugs[slugCandidate] + 1 : 1;
levelContent.id = linkifidIdForHash(pageifiedIdForHash(slug, pageKey));
}
}, hierarchicalDoc);
};
/**
* Returns menu data for a given HTML.
*
* menu = Flatdoc.transformer.getMenu($content);
* menu == {
* level: 0,
* items: [{
* section: "Getting started",
* level: 1,
* items: [...]}, ...]}
*/
Transformer.getMenu = function(runner, $content) {
var root = {items: [], id: '', level: 0};
var cache = [root];
function mkdir_p(level) {
cache.length = level + 1;
var obj = cache[level];
if (!obj) {
var parent = (level > 1) ? mkdir_p(level-1) : root;
obj = { items: [], level: level };
cache = cache.concat([obj, obj]);
parent.items.push(obj);
}
return obj;
}
var query = [];
if(runner.sidenavify.h1) {
query.push('h1');
}
if(runner.sidenavify.h2) {
query.push('h2');
}
if(runner.sidenavify.h3) {
query.push('h3');
}
if(runner.sidenavify.h4) {
query.push('h4');
}
if(runner.sidenavify.h5) {
query.push('h5');
}
if(runner.sidenavify.h6) {
query.push('h6');
}
$content.find(query.join(',')).each(function() {
var $el = $(this);
var level = +(this.nodeName.substr(1));
var parent = mkdir_p(level-1);
var text = $el.text();
var el = $el[0];
if(el.childNodes.length === 1 && el.childNodes[0].tagName === 'code' || el.childNodes[0].tagName === 'CODE') {
text = '<code>' + text + '</code>';
}
var obj = { section: text, items: [], level: level, id: $el.attr('id') };
parent.items.push(obj);
cache[level] = obj;
});
return root;
};
/**
* Changes "button >" text to buttons.
*/
Transformer.buttonize = function(content) {
$(content).find('a').each(function() {
var $a = $(this);
var m = $a.text().match(/^(.*) >$/);
if (m) $a.text(m[1]).addClass('button');
});
};
/**
* Applies smart quotes to a given element.
* It leaves `code` and `pre` blocks alone.
*/
Transformer.smartquotes = function (content) {
var nodes = getTextNodesIn($(content)), len = nodes.length;
for (var i=0; i<len; i++) {
var node = nodes[i];
node.nodeValue = quotify(node.nodeValue);
}
};
/**
* Syntax highlighters.
*
* You may add or change more highlighters via the `Flatdoc.highlighters`
* object.
*
* Flatdoc.highlighters.js = function(code) {
* };
*
* Each of these functions
*/
var Highlighters = Flatdoc.highlighters = {};
/**
* JavaScript syntax highlighter.
*
* Thanks @visionmedia!
*/
Highlighters.js = Highlighters.javascript = function(code) {
return code
.replace(/</g, '<')
.replace(/>/g, '>')
.replace(/("[^\"]*?")/g, '<span class="string">$1</span>')
.replace(/('[^\']*?')/g, '<span class="string">$1</span>')
.replace(/\/\/(.*)/gm, '<span class="comment">//$1</span>')
.replace(/\/\*(.*)\*\//gm, '<span class="comment">/*$1*/</span>')
.replace(/(\d+\.\d+)/gm, '<span class="number">$1</span>')
.replace(/(\d+)/gm, '<span class="number">$1</span>')
.replace(/\bnew *(\w+)/gm, '<span class="keyword">new</span> <span class="init">$1</span>')
.replace(/\b(function|new|throw|return|var|if|else)\b/gm, '<span class="keyword">$1</span>');
};
Highlighters.html = function(code) {
return code
.replace(/</g, '<')
.replace(/>/g, '>')
.replace(/("[^\"]*?")/g, '<span class="string">$1</span>')
.replace(/('[^\']*?')/g, '<span class="string">$1</span>')
.replace(/<!--(.*)-->/g, '<span class="comment"><!--$1--></span>')
.replace(/<([^!][^\s&]*)/g, '<<span class="keyword">$1</span>');
};
Highlighters.generic = function(code) {
return code
.replace(/</g, '<')
.replace(/>/g, '>')
.replace(/("[^\"]*?")/g, '<span class="string">$1</span>')
.replace(/('[^\']*?')/g, '<span class="string">$1</span>')
.replace(/(\/\/|#)(.*)/gm, '<span class="comment">$1$2</span>')
.replace(/(\d+\.\d+)/gm, '<span class="number">$1</span>')
.replace(/(\d+)/gm, '<span class="number">$1</span>');
};
/**
* Menu view. Renders menus
*/
var MenuView = Flatdoc.menuView = function(menu) {
var $el = $("<ul>");
function process(node, $parent) {
var id = node.id || 'root';
var nodeHashToChangeTo = hashForLinkifiedId(id);
var $li = $('<li>')
.attr('id', id + '-item')
.addClass('level-' + node.level)
.appendTo($parent);
if (node.section) {
var $a = $('<a>')
.html(node.section)
.attr('id', id + '-link')
.attr('href', '#' + nodeHashToChangeTo)
.addClass('level-' + node.level)
.appendTo($li);
$a.on('click', function() {
var foundNode = $('#' + node.id);
foundNode && $.highlightNode(foundNode);
});
}
if (node.items.length > 0) {
var $ul = $('<ul>')
.addClass('level-' + (node.level+1))
.attr('id', id + '-list')
.appendTo($li);
node.items.forEach(function(item) {
process(item, $ul);
});
}
}
process(menu, $el);
return $el;
};
/**
* A runner module that fetches via a `fetcher` function.
*
* var runner = new Flatdoc.runner({
* fetcher: Flatdoc.url('readme.txt')
* });
* runner.run();
*
* The following options are available:
*
* - `fetcher` - a function that takes a callback as an argument and
* executes that callback when data is returned.
*
* See: [Flatdoc.run()]
*/
var Runner = Flatdoc.runner = function(options) {
this.initialize(options);
};
Runner.prototype.pageRootSelector = 'body';
/**
* Really, is used to model internal *component* state based on entered
* control value. Like if a text input is empty, the text input component
* sets the search component to QueryStates.NONE_AND_HIDE.
* If the user hits enter on a dropdown selector, it toggles it between NONE
* and ALL.
*
* There's three bits of information per control that determine visibility:
*
* 1. Which component is "active" (like focused). This is currently modeled
* by activeSearchComponent (but that is almost redundant with document focus). It's not
* exactly the same as focused DOM element because we also want a component
* to be able to keep the popup open even if the user tabs to other parts of
* the document. That doesn't always make sense for every kind of component,
* but it's a feature. So activeSearchComponent recreates _another_ notion of active
* element apart from the document's.
* 2. Whether or not the internal state of the component warrants showing any
* popup. (QueryStates). Like a search input could have empty text which
* warrants showing no results. Or a dropdown component (which always has
* "empty text"), could be focused but it's not supposed to show any results
* until you click or press enter/space. That internal component state helps
* determine whether or not a popup should be shown. In the case of text
* input this is redundant or derivable from its input text (but not the case
* for other component types).
* 3. Whether or not the user requested that a popup for the currently active
* component be supressed. Even if 1 and 2 would otherwise result in showing
* a popup, the user could press escape.
* An autocomplete text input with non-empty input, that is currently focused
* (or "active") could press ctrl-c closing the popup window.
* A dropdown component could be "active", could have been clicked on, but
* the user could click a second time closing it (or pressing escape).
*/
var QueryStates = {
NONE: 'NONE',
ALL: 'ALL',
FILTER: 'FILTER'
};
function SearchComponentBase(root, pages) {
this.root = root;
this.pages = pages;
this.queryState = QueryStates.ALL;
this.results = [];
/**
* This state is managed both internally and externally. Internally,
* components know when they need to reset the user requested cursor. But
* externally search lists know when to reach out and mutate this.
*/
this.userRequestedCursor = null;
};
SearchComponentBase.effectiveCursorPosition = function() {
return this.userRequestedCursor === null
? 0
: this.userRequestedCursor;
}
function TextDocSearch(props) {
SearchComponentBase.call(this, props.root, props.pages);
this.queryState = QueryStates.FILTER;
var placeholder = this.getPlaceholder();
if(this.root.tagName.toUpperCase() !== 'FORM') {
console.error('You provided a searchFormId that does not exist');
return;
}
var theSearchInput;
var theSearchClear;
if(this.root.className.indexOf('bookmark-search-form-already-setup') !== -1) {
theSearchInput = this.root.childNodes[0];
theSearchClear = this.root.childNodes[1];
} else {
this.root.className += ' bookmark-search-form bookmark-search-form-already-setup';
this.root.onsubmit="";
var theSearchInput = document.createElement('input');
theSearchInput.name = 'focus';
theSearchInput.className = 'bookmark-search-input';
theSearchInput.placeholder = placeholder;
theSearchInput.required = true;
theSearchClear = document.createElement('button');
theSearchClear.tabindex=1;
theSearchClear.className='bookmark-search-input-right-reset-icon';
theSearchClear.type='reset';
theSearchClear.tabIndex=-1;
this.root.prepend(theSearchClear);
this.root.prepend(theSearchInput);
}
this.theSearchInput = theSearchInput;
theSearchInput.addEventListener('focus', function(e) {
var focusedPlaceholder = this.getFocusedPlaceholder(this.root);
theSearchInput.placeholder = focusedPlaceholder;
if(this.userRequestedCursor === -1) {
this.userRequestedCursor = null;
}
if(this.valueWarrantsHiding()) {
props.onDoesntWantActiveStatus && props.onDoesntWantActiveStatus(this);
} else {
props.onWantsToHaveActiveStatus && props.onWantsToHaveActiveStatus(this);
}
props.onFocus && props.onFocus(e);
}.bind(this));
theSearchInput.addEventListener('keydown', function(e) {
props.onKeydown && props.onKeydown(e);
}.bind(this));
theSearchInput.addEventListener('input', function(e) {
this.userRequestedCursor = null;
if(this.valueWarrantsHiding()) {
props.onDoesntWantActiveStatus && props.onDoesntWantActiveStatus(this);
} else {
props.onWantsToHaveActiveStatus && props.onWantsToHaveActiveStatus(this);
}
props.onInput && props.onInput(e);
}.bind(this));
theSearchInput.addEventListener('blur', function(e) {
var focusedPlaceholder = this.getPlaceholder();
theSearchInput.placeholder = focusedPlaceholder;
props.onBlur && props.onBlur(e);
}.bind(this));
// This one goes on the form itself
this.root.addEventListener('reset', function() {
this.setValue('');
this.focus();
this.userRequestedCursor = null;
props.onDoesntWantActiveStatus && props.onDoesntWantActiveStatus(this);
if(props.onReset) {
props.onReset
}
}.bind(this));
this.root.addEventListener('submit', function(e) {
e.preventDefault();
}.bind(this));
};
TextDocSearch.prototype.getQuery = function() {
return this.getValue().trim();
};
TextDocSearch.prototype.valueWarrantsHiding = function() {
return this.getValue().trim() === '';
};
TextDocSearch.prototype.effectiveCursorPosition = SearchComponentBase.effectiveCursorPosition;
TextDocSearch.prototype.getFocusedPlaceholder = function() {
var defaultTxt = "Search (Esc close)";
return this.root ?
(this.root.dataset.focusedPlaceholder || defaultTxt) :
defaultTxt;
};
TextDocSearch.prototype.getPlaceholder = function(root) {
var defaultTxt = "Press '/' to focus" ;
return this.root ?
(this.root.dataset.placeholder || defaultTxt) :
defaultTxt;
};
TextDocSearch.prototype.focus = function() {
return this.theSearchInput.focus();
};
TextDocSearch.prototype.selectAll = function() {
return this.theSearchInput.select();
};
TextDocSearch.prototype.isFocused = function() {
return document.activeElement === this.theSearchInput;
};
TextDocSearch.prototype.blur = function() {
return this.theSearchInput.blur();
};
TextDocSearch.prototype.getValue = function() {
return this.theSearchInput.value;
};
TextDocSearch.prototype.setValue = function(v) {
this.theSearchInput.value = v;
};
TextDocSearch.prototype.setPlaceholder = function(ph) {
this.theSearchInput.placeholder = ph;
};
TextDocSearch.prototype.isSearchable = isNodeSearchHit;
TextDocSearch.prototype.onLostActiveSearchComponent = function() {
// this.queryState = QueryStates.NONE_AND_HIDE;
};
TextDocSearch.prototype.onGainedActiveSearchComponent = function() {
// this.queryState = QueryStates.ALL;
};
/**
* An "input selector" style component that uses the navigation autocomplete window.
*/
function TextDocSelector(props) {
SearchComponentBase.call(this, props.root, props.pages);
this.queryState = QueryStates.ALL;
this.root.addEventListener('focus', function(e) {
if(this.userRequestedCursor === -1) {
this.userRequestedCursor = null;
}
props.onFocus && props.onFocus(e);
});
this.root.addEventListener('keydown', function(e) {
props.onKeydown && props.onKeydown(e);
});
this.root.addEventListener('click', function(e) {
if(props.isActiveComponent()) {
props.onDoesntWantActiveStatus && props.onDoesntWantActiveStatus(this);
} else {
props.onWantsToHaveActiveStatus && props.onWantsToHaveActiveStatus(this);
}
}.bind(this));
this.root.addEventListener('blur', function() {
props.onDoesntWantActiveStatus && props.onDoesntWantActiveStatus(this);
}.bind(this));
};
TextDocSelector.prototype.isSearchable = isNodeSearchHit;
TextDocSelector.prototype.getQuery = function() {
return '';
};
TextDocSelector.prototype.onLostActiveSearchComponent = function() {
};
TextDocSelector.prototype.onGainedActiveSearchComponent = function() {
};
TextDocSelector.prototype.effectiveCursorPosition = SearchComponentBase.effectiveCursorPosition;
/**
* Custom methods (extends base API for search components).
*/
Runner.prototype.initialize = function(options) {
this.pageState = {};
this.searchState = {
/**
* "global" state - across all searches.
*/
activeSearchComponent: null,
/**
* Typically until the next event that switches the active component.
*/
userRequestedCloseEvenIfActive: true,
VERSIONS: null,
CONTENT: null
}
this.nodes = {
theSearchHits: null,
theHitsScrollContainer: null,
versionMenuButton: null,
versionsContainer: null
}
$.extend(this, options);
};
/**
* Syntax highlighting.
*
* You may define a custom highlight function such as `highlight` from
* the highlight.js library.
*
* Flatdoc.run({
* highlight: function (code, value) {
* return hljs.highlight(lang, code).value;
* },
* ...
* });
*
*/
/**
* There is only one active search component. It is the one that will be
* responsible for providing search results. The moment a different component
* becomes the new active component, the new active component determines
* which results will be shown, and helps decide whether or not to show the
* popup menu at all.
*/
Runner.prototype.setActiveSearchComponent = function(newComp) {
if(newComp !== this.searchState.activeSearchComponent) {
if(this.searchState.activeSearchComponent) {
this.searchState.activeSearchComponent.onLostActiveSearchComponent();
}
this.searchState.activeSearchComponent = newComp;
this.searchState.userRequestedCloseEvenIfActive = false;
if(this.searchState.activeSearchComponent) {
this.searchState.activeSearchComponent.onGainedActiveSearchComponent();
}
}
};
Runner.prototype.highlight = function(code, lang) {
var fn = Flatdoc.highlighters[lang] || Flatdoc.highlighters.generic;
return fn(code);
};
Runner.prototype.noResultsNode = function(query) {
var d = document.createElement('div');
d.className = "bookmark-hits-noresults-list";
d.innerText = 'No results for "' + query + '"';
return d;
};
Runner.prototype.getHitsScrollContainer = function() {
return this.nodes.theHitsScrollContainer;
};
Runner.prototype.effectiveCursorPosition = function(searchComponent) {
return searchComponent.userRequestedCursor === null
? 0
: searchComponent.userRequestedCursor;
}
Runner.prototype.updateSearchResultsList = function(searchComponent, query, results, clickHandler) {
var doc = this;
// var isNowVisible = doc.updateSearchHitsVisibility(searchComponent);
// // If toggling to invisible, do not change the rendered list. The reason is
// // that we want existing contents to always fade out instead of changing the list contents
// // while fading out.
// if(!isNowVisible) {
// return;
// }
var hitsScrollContainer = this.getHitsScrollContainer();
var firstItem = null;
var lastItem = null;
var effectiveCursorPosition = this.effectiveCursorPosition(searchComponent);
if(!results.length) {
var len = hitsScrollContainer.childNodes.length;
for(var i = 0; i < len; i++) {
hitsScrollContainer.removeChild(hitsScrollContainer.childNodes[i]);
}
hitsScrollContainer.appendChild(this.noResultsNode(query));
} else {
var existingHitsList;
var hitsList;
if(hitsScrollContainer.childNodes[0] && hitsScrollContainer.childNodes[0].className === 'bookmark-hits-noresults-list') {
existingHitsList = null;
hitsScrollContainer.removeChild(hitsScrollContainer.childNodes[0]);
} else {
existingHitsList = hitsScrollContainer.childNodes[0];
}
if(!existingHitsList) {
hitsList = document.createElement('div');
hitsList.className = 'bookmark-hits-list';
hitsScrollContainer.appendChild(hitsList);
} else {
hitsList = existingHitsList;
}
var numExistingHitsListItems = existingHitsList ? existingHitsList.childNodes.length : 0;
for(var i = results.length; i < numExistingHitsListItems; i++) {
existingHitsList.removeChild(existingHitsList.childNodes[existingHitsList.childNodes.length - 1]);
}
for(var i = 0; i < results.length; i++) {
var category = results[i].category;
var textContent = results[i].content;
var _highlightResultContentValue = results[i].matchedSearchable.highlightedInnerText;
var topRow = results[i].matchedSearchable.topRow;
var hitsItem;
var cursor = null;
// Reuse dom nodes to avoid flickering of css classes/animation.
if(existingHitsList && existingHitsList.childNodes[i]) {
hitsItem = existingHitsList.childNodes[i];
$(hitsItem).off('click');
hitsItem.removeChild(hitsItem.childNodes[0]);
} else {
hitsItem = document.createElement('div');
hitsItem.tabIndex = -1;
hitsItem.className = 'bookmark-hits-item';
hitsList.appendChild(hitsItem);
}
if(effectiveCursorPosition === i) {
cursor = $(hitsItem)[0];
$(hitsItem).addClass('cursor');
} else {
$(hitsItem).removeClass('cursor');
}
$(hitsItem).on('click', function(i, e) {
clickHandler(searchComponent, query, results, i, e);
}.bind(null, i));
var buttonContents = document.createElement('div');
buttonContents.className='bookmark-hits-item-button-contents';
buttonContents.innerHTML = _highlightResultContentValue;
topRow && buttonContents.insertBefore(topRow, buttonContents.firstChild);
hitsItem.appendChild(buttonContents);
if(cursor) {
customScrollIntoView({
smooth: true,
container: hitsScrollContainer,
element: cursor,
mode: 'closest-if-needed',
topMargin: 10,
bottomMargin: 10
});
}
}
}
};
Runner.prototype._createTopRow = function(row, context, level) {
row = document.createElement('div');
row.className = 'bookmark-hits-item-button-contents-top-row';
var crumb = document.createElement('div');
crumb.className = 'bookmark-hits-item-contents-top-row-crumb';
var tags = document.createElement('div');
tags.className = 'bookmark-hits-item-contents-top-row-tags';
row.appendChild(crumb);
row.appendChild(tags);
return row;
};
Runner.prototype._appendContextCrumb = function(row, context, level) {
if(!row) {
row = this._createTopRow();
}
if(context[level]) {
if(row.childNodes[0].childNodes.length > 0) {
var chevron = document.createElement('span');
chevron.className = 'bookmark-hits-item-button-contents-crumb-sep';
chevron.innerText = '›';
// Append to the crumb child
row.childNodes[0].appendChild(chevron);
}
var seg = document.createElement('span');
seg.className = 'bookmark-hits-item-button-contents-crumb-row-first';
seg.innerText = context[level].levelContent[0].innerText;
row.childNodes[0].appendChild(seg);
}
return row;
};
Runner.prototype.topRowForDocSearch = function(context, node) {
var searchBreadcrumbContext =
this.searchBreadcrumbContext ? this.searchBreadcrumbContext :
defaultSearchBreadcrumbContext;
var context = searchBreadcrumbContext(context);
var row = this._appendContextCrumb(null, context, 'h1');
row = this._appendContextCrumb(row, context, 'h2');
row = this._appendContextCrumb(row, context, 'h3');
row = this._appendContextCrumb(row, context, 'h4');
row = this._appendContextCrumb(row, context, 'h5');
row = this._appendContextCrumb(row, context, 'h6');
return row;
};
Runner.prototype.setupHitsScrollContainer = function() {
var theSearchHitsId = this.searchHitsId;
var theSearchHits = document.getElementById(theSearchHitsId);
var hitsScrollContainer = theSearchHits.childNodes[0];
var hitsScrollContainerAppearsSetup =
hitsScrollContainer &&
hitsScrollContainer.className.indexOf('bookmark-hits-scroll') !== -1;
// After this then this.getHitsScrollContainer() will work:
// We are probably reviving a prerendered page
if(theSearchHits && hitsScrollContainerAppearsSetup) {
this.nodes.theSearchHits = theSearchHits;
this.nodes.theHitsScrollContainer = hitsScrollContainer;
} else if(theSearchHits && !hitsScrollContainer) {
hitsScrollContainer = document.createElement('div');
var hiddenClass = 'bookmark-hits-scroll bookmark-hits-scroll-hidden';
hitsScrollContainer.className = hiddenClass;
theSearchHits.appendChild(hitsScrollContainer);
this.nodes.theSearchHits = theSearchHits;
this.nodes.theHitsScrollContainer = hitsScrollContainer;
} else if(theSearchHitsId) {
console.error(
'You supplied options searchHitsId but we could not find one of the elements ' + theSearchHitsId +
'. Either that or something is wrong with the pre-rendering of the page'
);
}
/**
* Prevent blur from any existing controls that already have focus by
* preventDefault on mouseDown event.
* You can still style the mouse down state by using the css :active
* pseudo-class.
*/
hitsScrollContainer.addEventListener('mousedown', function(e) {e.preventDefault();});
};
Runner.prototype.getItemForCursor = function(i) {
var hitsScrollContainer = this.getHitsScrollContainer();
var maybeHitsList = hitsScrollContainer.childNodes[0];
return maybeHitsList.className.indexOf('bookmark-hits-list') === -1 ? null :
maybeHitsList.childNodes[i];
}
// alert('TODO: When clicking on document, set the active mode to null - let compeonts decide what they want to do when they are no longer the active mode. Dropdowns can reset their querystate to NONE. Autocompletes would not. Then make it so that all components get a notification for any active state transition away from them (or maybe even to them).');
Runner.prototype.shouldSearchBeVisible = function(activeSearchComponent) {
if(!activeSearchComponent) {
return false;
}
if(this.searchState.userRequestedCloseEvenIfActive) {
return false;
} else {
return true;
// return activeSearchComponent.queryState !== QueryStates.NONE_AND_HIDE;
}
};
Runner.prototype.setupSearchInput = function() {
var doc = this;
var theSearchFormId = doc.searchFormId;
if(theSearchFormId) {
var theSearchForm = document.getElementById(theSearchFormId);
doc.searchState.CONTENT = new TextDocSearch({
root: theSearchForm,
pages: doc.pageState,
/**
* When input is blurred we do not set the active component to null.
*/
onBlur: function inputBlur(e) {
console.log('blur input');
},
// TODO: Rembember last focused element so that escape can jump back to it.
// Ctrl-c can toggle open, and Esc can toggle open + focus.
// When hitting enter it can reset the "last focused" memory.
onFocus: function doInputFocus(e) {
if(window['bookmark-header']) {
window['bookmark-header'].scrollIntoView({behavior: 'smooth'});
}
},
onDoesntWantActiveStatus: function(comp) {
console.log('search input doesnt want');
if(doc.searchState.activeSearchComponent === comp) {
doc.setActiveSearchComponent(null);
doc.updateSearchHitsVisibility(doc.searchState.activeSearchComponent);
}
},
/**
* When the component wants the popup menu to be shown for it, and it
* has a useful (or new) .getQuery() that can be polled.
*/
onWantsToHaveActiveStatus: function(comp) {
doc.setActiveSearchComponent(comp);
// Upon focus, reselect the first result cursor, otherwise keep old one
console.log("text input wants to have active status");
doc.runSearchWithInputValue();
},
onKeydown: function(e) {return doc.handleSearchComponentKeydown(doc.searchState.CONTENT, e)},
/**
* Allow components to test if they are the active component.
*/
isActiveComponent: function() {
return doc.searchState.activeSearchComponent === doc.searchState.CONTENT;
}
});
}
};
Runner.prototype.searchDocsWithActiveSearchComponent = function(query, renderTopRow, contentRoot) {
var doc = this;
var searchComponent = doc.searchState.activeSearchComponent;
hierarchicalIndexForSearch(doc.pageState)
var hits = [];
console.log(searchComponent.queryState);
if(searchComponent.queryState === QueryStates.ALL) {
console.log('noop filter', doc.pageState);
return noopHierarchicalFilter(doc.pageState, renderTopRow).map(matchedSearchableToHit);
} else if(searchComponent.queryState === QueryStates.FILTER) {
var filteredHierarchicalSearchables = filterHierarchicalSearchables(query, doc.pageState, renderTopRow);
hits = filteredHierarchicalSearchables.map(matchedSearchableToHit);
return hits;
} else {
console.error('Unknown query state', searchComponent.queryState, 'for component', searchComponent);
}
};
Runner.prototype.runSearchWithInputValue = function () {
var doc = this;
var theTextDocSearch = doc.searchState.CONTENT;
if(doc.searchState.activeSearchComponent === theTextDocSearch) {
var query = theTextDocSearch.getQuery();
var results = doc.searchDocsWithActiveSearchComponent(
query,
doc.topRowForDocSearch.bind(doc)
);
doc.searchState.activeSearchComponent.results = results;
doc.updateSearchResultsList(doc.searchState.activeSearchComponent, query, results, doc.standardResultsClickHandler.bind(doc));
doc.updateSearchHitsVisibility(doc.searchState.activeSearchComponent);
}
};
Runner.prototype.setupVersionButton = function () {
var doc = this;
if(this.versionButtonId && this.versionPageIs) {
var versionMenuButton = document.getElementById(this.versionButtonId);
var versionContentsContainer =
this.pageState[this.versionPageIs].contentContainerNode;
if(!versionMenuButton) {
console.error('Version menu selector/content with id ', this.versionButtonId, ' doesnt exist');
}
if(!versionContentsContainer) {
console.error(
'Page for config option "versionPageIs" does not exist: ',
this.versionButtonId,
'. There should be a page key in your "pages" config with that name'
);
}
this.searchState.VERSIONS = new TextDocSelector({
root: versionMenuButton,
pages: Flatdoc.keepOnly(doc.pageState, (pageData, pageKey) => this.versionPageIs.toLowerCase() === pageKey),
onKeydown: function(e) {return this.handleSearchComponentKeydown(doc.searchState.VERSIONS, e)}.bind(this),
onWantsToHaveActiveStatus: function(comp) {
doc.setActiveSearchComponent(comp);
// Upon focus, reselect the first result cursor, otherwise keep old one
console.log("version selector wants to have active status");
doc.runVersionsSearch();
},
/**
* Allow components to test if they are the active component.
*/
isActiveComponent: function() {
return doc.searchState.activeSearchComponent === doc.searchState.VERSIONS;
},
onDoesntWantActiveStatus: function(comp) {
console.log('vversion doesnt want');
if(doc.searchState.activeSearchComponent === comp) {
doc.setActiveSearchComponent(null);
doc.updateSearchHitsVisibility(doc.searchState.activeSearchComponent);
}
},
onBlur: function inputBlur(e) {
console.log('blur input');
},
// TODO: Rembember last focused element so that escape can jump back to it.
// Ctrl-c can toggle open, and Esc can toggle open + focus.
// When hitting enter it can reset the "last focused" memory.
onFocus: function doInputFocus(e) {
if(window['bookmark-header']) {
window['bookmark-header'].scrollIntoView({behavior: 'smooth'});
}
},
});
}
};
Runner.prototype.updateSearchHitsVisibility = function(searchComponent) {
console.log('updateSearchHitsVisibility');
var hitsScrollContainer = this.nodes.theHitsScrollContainer;
if(!this.shouldSearchBeVisible(searchComponent)) {
hitsScrollContainer.className = 'bookmark-hits-scroll bookmark-hits-scroll-hidden';
return false;
} else {
hitsScrollContainer.className = 'bookmark-hits-scroll';
return true;
}
};
Runner.prototype.handleSearchComponentKeydown = function(searchComponent, evt) {
var doc = this;
// alert('need to make sure the active component is set here');
var effectiveCursorPosition = doc.effectiveCursorPosition(searchComponent);
var isVisible = doc.shouldSearchBeVisible(searchComponent);
var nextIndex;
if (evt.keyCode === 40 /* down */) {
if(!isVisible && searchComponent.getQuery() !== "") {
// Promote to zero on first down if neg one
nextIndex = Math.max(searchComponent.userRequestedCursor, 0);
doc.searchState.userRequestedCloseEvenIfActive = false;
} else {
nextIndex = (effectiveCursorPosition < searchComponent.results.length - 1)
? effectiveCursorPosition + 1
: searchComponent.userRequestedCursor;
}
}
if (evt.keyCode === 38 /* up */) {
if(effectiveCursorPosition !== -1) {
nextIndex = effectiveCursorPosition - 1;
} else {
nextIndex = searchComponent.userRequestedCursor;
}
}
if (evt.keyCode === 38 || evt.keyCode === 40) {
searchComponent.userRequestedCursor = nextIndex;
}
if(isVisible && evt.keyCode === 13) { // enter
var itemForCursor = doc.getItemForCursor(effectiveCursorPosition);
$(itemForCursor).trigger('click');
} else if(!isVisible && evt.keyCode === 13) {
doc.searchState.userRequestedCloseEvenIfActive = false;
} else if(evt.keyCode === 27) {
// console.log('local escape');
// // Let's make escape close and blur
// $(theSearchInput).blur();
// doc.searchState.userRequestedCloseEvenIfActive = !doc.searchState.userRequestedCloseEvenIfActive;
// doc.updateSearchHitsVisibility(searchComponent);
} else if(evt.keyCode === 67 && evt.ctrlKey) { // esc or ctrl-c
// But ctrl-c can toggle without losing focus
// doc.searchState.userRequestedCloseEvenIfActive = !doc.searchState.userRequestedCloseEvenIfActive;
// doc.updateSearchHitsVisibility(searchComponent);
}
// Either way, visible or not - if enter is pressed, prevent default.
// Because a "required" form field that is empty will submit on enter and
// then make an ugly Chrome popup saying "this is required".
if (evt.keyCode === 38 || evt.keyCode === 40 || evt.keyCode === 13) {
evt.preventDefault();
doc.updateSearchResultsList(
searchComponent,
searchComponent.getQuery(),
searchComponent.results,
doc.standardResultsClickHandler.bind(doc)
);
}
};
Runner.prototype.deepestContextWithSlug = function(context) {
return context.h6 && context.h6.id ? context.h6 :
context.h5 && context.h5.id ? context.h5 :
context.h4 && context.h4.id ? context.h4 :
context.h3 && context.h3.id ? context.h3 :
context.h2 && context.h2.id ? context.h2 :
context.h1 && context.h1.id ? context.h1 : null;
};
Runner.prototype.standardResultsClickHandler = function(searchComponent, query, results, i, e) {
var doc = this;
searchComponent.userRequestedCursor = i;
// doc.searchState.userRequestedCloseEvenIfActive = true;
// doc.updateSearchHitsVisibility();
doc.updateSearchResultsList(searchComponent, query, results, doc.standardResultsClickHandler.bind(doc));
var node = results[i].matchedSearchable.searchable.node;
$.highlightNode(node);
customScrollIntoView({
smooth: true,
container: 'page',
element: node,
mode: 'top',
topMargin: 2 * headerHeight,
bottomMargin: 0
});
};
Runner.prototype.setupSearch = function() {
var doc = this;
doc.setupSearchInput();
doc.setupVersionButton();
doc.setupHitsScrollContainer();
var theTextDocSearch = doc.searchState.CONTENT;
var theSearchHits = doc.nodes.theSearchHits;
if(!theTextDocSearch || !theSearchHits) {
return;
}
var hitsScrollContainer = doc.nodes.theHitsScrollContainer;
doc.nodes.theSearchHits.style.cssText += "position: sticky; top: " + (headerHeight - 1) + "px; z-index: 100;"
function setupGlobalKeybindings() {
window.document.body.addEventListener('keypress', e => {
if(!theTextDocSearch.isFocused() && e.key === "/") {
theTextDocSearch.focus()
theTextDocSearch.selectAll()
e.preventDefault();
}
});
}
document.addEventListener('keydown', function (evt) {
if(evt.keyCode === 27) {
console.log('global escape');
// Let's make escape close and blur
if(theTextDocSearch.isFocused()) {
theTextDocSearch.blur();
}
if(!doc.searchState.userRequestedCloseEvenIfActive) {
doc.searchState.userRequestedCloseEvenIfActive = true;
}
doc.setActiveSearchComponent(null);
// Maybe updateSearchHitsVisibility should happen in setActiveSearchComponent.
doc.updateSearchHitsVisibility(doc.searchState.activeSearchComponent);
} else if(evt.keyCode === 67 && evt.ctrlKey) { // esc or ctrl-c
// But ctrl-c can toggle without losing focus
doc.searchState.userRequestedCloseEvenIfActive = !doc.searchState.userRequestedCloseEvenIfActive;
doc.updateSearchHitsVisibility(doc.searchState.activeSearchComponent);
}
// alert('todo have ctrl-c keep the current active component, but tell that component to go to QueryMode.NONE_AND_HIDE');
});
setupGlobalKeybindings();
function onGlobalClickOff(e) {
doc.setActiveSearchComponent(null);
// We'll consider all other search modes to be "ephemeral".
doc.updateSearchHitsVisibility(null);
// e.stopPropagation();
}
document.querySelectorAll('.bookmark-content-root')[0].addEventListener('click', onGlobalClickOff);
};
Runner.prototype.topRowForVersionSearch = function(context, node) {
var topRow = this.topRowForDocSearch(context, node);
var tagsDiv = topRow.childNodes[1];
var tag = document.createElement('div');
tag.className = 'bookmark-hits-item-contents-top-row-tags-tag';
tag.innerText = "Latest";
tagsDiv.appendChild(tag);
return topRow;
};
Runner.prototype.runVersionsSearch = function runVersionsSearch() {
var doc = this;
var searchComponent = doc.searchState.VERSIONS;
if(window['bookmark-header']) {
window['bookmark-header'].scrollIntoView({behavior: 'smooth'});
}
doc.setActiveSearchComponent(searchComponent);
console.log('running version search');
// TODO: Reset this to NONE on blur/selection etc.
doc.updateSearchHitsVisibility(doc.searchState.VERSIONS);
var results = doc.searchDocsWithActiveSearchComponent(
searchComponent.getQuery(),
doc.topRowForVersionSearch.bind(doc)
);
searchComponent.results = results;
doc.updateSearchResultsList(searchComponent, searchComponent.getQuery(), results, doc.standardResultsClickHandler.bind(doc));
};
Runner.prototype.makeCodeTabsInteractive = function() {
$('codetabbutton').each(function(i, e) {
var forTabContainerId = e.dataset.forContainerId;
var index = e.dataset.index;
$(e).on('click', function(evt) {
var tabContainer = e.parentNode;
console.log('searching this query what: $("' + '#' + forTabContainerId + ' codetabbutton")');
$(e).addClass('bookmark-codetabs-active');
$(tabContainer).removeClass('bookmark-codetabs-active1');
$(tabContainer).removeClass('bookmark-codetabs-active2');
$(tabContainer).removeClass('bookmark-codetabs-active3');
$(tabContainer).removeClass('bookmark-codetabs-active4');
$(tabContainer).removeClass('bookmark-codetabs-active5');
$(tabContainer).addClass('bookmark-codetabs-active' + index);
});
});
};
/**
* Remove any nodes that are not needed once rendered. This way when
* generating a pre-rendered `.rendered.html`, they won't become part of the
* bundle, when that rendered page is turned into a `.html` bundle. They have
* served their purpose. Add `class='removeFromRenderedPage'` to anything you
* want removed once used to render the page. (Don't use for script tags that
* are needed for interactivity).
*/
Runner.prototype.removeFromRenderedPage = function() {
$('.removeFromRenderedPage').each(function(i, e) {
e.parentNode.removeChild(e);
});
};
/**
* See documentation for `continueRight` css class in style.styl.
*/
Runner.prototype.fixupAlignment = function() {
document.querySelectorAll(
// TODO: Add the tabs container here too.
'.bookmark-content > img + pre,' +
'.bookmark-content > img + blockquote,' +
'.bookmark-content > p + pre,' +
'.bookmark-content > p + blockquote,' +
'.bookmark-content > ul + pre,' +
'.bookmark-content > ul + blockquote,' +
'.bookmark-content > ol + pre,' +
'.bookmark-content > ol + blockquote,' +
'.bookmark-content > h0 + pre,' +
'.bookmark-content > h0 + blockquote,' +
'.bookmark-content > h1 + pre,' +
'.bookmark-content > h1 + blockquote,' +
'.bookmark-content > h2 + pre,' +
'.bookmark-content > h2 + blockquote,' +
'.bookmark-content > h3 + pre,' +
'.bookmark-content > h3 + blockquote,' +
'.bookmark-content > h4 + pre,' +
'.bookmark-content > h4 + blockquote,' +
'.bookmark-content > h5 + pre,' +
'.bookmark-content > h5 + blockquote,' +
'.bookmark-content > h6 + pre,' +
'.bookmark-content > h6 + blockquote,' +
'.bookmark-content > table + pre,' +
'.bookmark-content > table + blockquote'
).forEach(function(e) {
// Annotate classes for the left and right items that are "resynced".
// This allows styling them differently. Maybe more top margins. TODO:
// I don't think that bookmark-synced-up-left is needed. continueRight
// seems to do the trick and the css for bookmark-synced-up-left seems to
// just ruin it actually.
e.className += 'bookmark-synced-up-right';
if(e.previousSibling) {
e.previousSibling.className += 'bookmark-synced-up-left';
}
})
};
Runner.prototype.setupLeftNavScrollHighlighting = function() {
var majorHeaders = $("h2, h3");
majorHeaders.length && majorHeaders.scrollagent(function(cid, pid, currentElement, previousElement) {
console.log('setting up scroll watchers for pid', pid);
if (pid) {
$("[href='#"+hashForLinkifiedId(pid)+"']").removeClass('active');
}
if (cid) {
$("[href='#"+hashForLinkifiedId(cid)+"']").addClass('active');
}
});
};
Runner.prototype.handleHashChange = function(hash) {
if (hash !== ''){
console.log('hash changed', hash);
if(hash[0] === '#') {
hash = hash.substring(1);
anchorJump('#' + linkifidIdForHash(hash));
}
}
};
Runner.prototype.waitForImages = function() {
var onAllImagesLoaded = function() {
// Has to be done after images are loaded for correct detection of position.
this.setupLeftNavScrollHighlighting();
window.addEventListener('hashchange', function(e) {
this.handleHashChange(location.hash);
}.bind(this));
// Rejump after images have loaded
this.handleHashChange(location.hash);
/**
* If you add a style="visibility:hidden" to your document body, we will clear
* the style after the styles have been injected. This avoids a flash of
* unstyled content.
* Only after scrolling and loading a stable page with all styles, do we
* reenable visibility.
* TODO: This is only needed if there is a hash in the URL. Otherwise,
* we can show the page immediately, non-blocking since we don't need to scroll
* to the current anchor. (We don't need to wait for images to load which are
* likely below the fold). This assumes we can implement a header that is scalable
* entirely in css. As soon as styles are loaded, the visibility can be shown.
*/
console.log('all images loaded at', Date.now());
if(window.location.hash) {
document.body.style="visibility: visible";
} else {
console.log('Lack of hash in URL saved time in display:', Date.now() - window._bookmarkTimingStyleReady);
}
}.bind(this);
var imageCount = $('img').length;
var nImagesLoaded = 0;
// Wait for all images to be loaded by cloning and checking:
// https://cobwwweb.com/wait-until-all-images-loaded
// Thankfully browsers cache images.
function onOneImageLoaded(loadedEl) {
nImagesLoaded++;
if (nImagesLoaded == imageCount) {
onAllImagesLoaded();
}
}
if(imageCount === 0) {
onAllImagesLoaded();
} else {
$('img').each(function(_i, imgEl) {
$('<img>').on('load', onOneImageLoaded).attr('src', $(imgEl).attr('src'));
$('<img>').on('error', onOneImageLoaded).attr('src', $(imgEl).attr('src'));
});
}
};
Runner.prototype.run = function(
onCurrentRenderPageDone, onAllRenderPagesDone, onNextIndexPageDone, onAllIndexPagesDone) {
};
/**
* Loads the Markdown document (via the fetcher), parses it, and applies it
* to the elements.
*/
Runner.prototype.run = function(
onCurrentRenderPageDone, onAllRenderPagesDone, onNextIndexPageDone, onAllIndexPagesDone) {
var start = Date.now();
var doc = this;
$(doc.pageRootSelector).trigger('flatdoc:loading');
$(doc.pageRootSelector).on('flatdoc:ready', this.makeCodeTabsInteractive);
$(doc.pageRootSelector).on('flatdoc:ready', this.removeFromRenderedPage.bind(this));
$(doc.pageRootSelector).on('flatdoc:ready', this.fixupAlignment.bind(this));
$(doc.pageRootSelector).on('flatdoc:ready', this.waitForImages.bind(this));
// If this *is* an already rendered snapshot, then no need to render
// anything. Just fire off the ready events so that hacky jquery code can
// perform resizing etc.
$(doc.pageRootSelector).on('flatdoc:ready', function(e) {
doc.makeCodeTabsInteractive();
doc.setupSearch();
// Need to focus the window so global keyboard shortcuts are heard.
$(window).focus()
});
if(document.body.className.indexOf('bookmark-already-rendered') !== -1) {
$(doc.pageRootSelector).trigger('flatdoc:style-ready');
$(doc.pageRootSelector).trigger('flatdoc:ready');
return;
}
document.body.className += ' bookmark-already-rendered';
var stylusFetchedYet = !doc.stylusFetcher;
var allDocsFetchedYet = false;
var everythingFetchedYet = false;
var stylusResult = null;
function handleDones() {
var foundUnfetchedDoc = false;
Flatdoc.forEachPage(
doc.pageState,
function(chapData, _) {
foundUnfetchedDoc = foundUnfetchedDoc || chapData.markdownAndHeader === null;
}
);
var wasEverythingFetchedYetBefore = allDocsFetchedYet && stylusFetchedYet;
if(!allDocsFetchedYet && !foundUnfetchedDoc) {
allDocsFetchedYet = true;
doc.handleDocsFetched();
}
if(!stylusFetchedYet && !!stylusResult) {
stylusFetchedYet = true;
$(doc.pageRootSelector).trigger('flatdoc:style-ready');
}
everythingFetchedYet = allDocsFetchedYet && stylusFetchedYet;
if(everythingFetchedYet && !wasEverythingFetchedYetBefore) {
$(doc.pageRootSelector).trigger('flatdoc:ready');
}
};
var fetchOne = function(fetcher, cb) {
fetcher(function(err, md) {
if(err) {
cb(err, null);
return;
}
var markdown = normalizeMarkdownResponse(md);
var markdownNormalizedCodeTabs = normalizeDocusaurusCodeTabs(markdown);
var markdownNormalizedYaml = normalizeYamlMarkdownComments(markdownNormalizedCodeTabs);
var markdownAndHeader = parseYamlHeader(markdownNormalizedYaml, window.location.pathname);
// Parse out the YAML header if present.
var data = markdownAndHeader;
/* Flatdoc.parser.parse(
doc,
markdownAndHeader,
doc.highlight,
pageState,
pageKey
); */
// About 258
cb(err, data);
});
};
Flatdoc.forEachPage(
doc.pageState,
function(pageData, pageKey) {
fetchOne(pageData.fetcher, function(err, data) {
doc.pageState[pageKey].markdownAndHeader = data;
err && console.error(
'[Flatdoc] fetching Markdown data failed for page:' + pageKey + '.',
err
);
handleDones();
})
},
);
if(doc.stylusFetcher) {
var templateFetchStart = Date.now();
doc.stylusFetcher(function(err, stylusTxt) { // Will run sync
doc.renderAndInjectStylus(err, stylusTxt, function(res) {
stylusResult = res;
handleDones();
});
});
}
};
Runner.prototype.renderAndInjectStylus = function(err, stylusTxt, cb) {
if(err) {
console.error('[Flatdoc] fetching Stylus data failed.', err);
cb('');
} else {
window.stylus.render(stylusTxt, function(err, result) {
if(err) {
console.error('Stylus error:' + err.message);
cb('');
} else {
var style = document.createElement('style');
style.type = 'text/css';
style.name = 'style generated from .styl.html file';
style.innerHTML = result;
document.getElementsByTagName('head')[0].appendChild(style);
cb(stylusTxt);
}
});
}
};
Runner.prototype.handleDocsFetched = function() {
var runner = this;
function appendExperience(pageKey, pageData) {
var markdownAndHeader = pageData.markdownAndHeader;
marked = exports.marked;
Parser.setMarkedOptions(runner.highlight);
var premangledContent = $("<div>" + marked(markdownAndHeader.markdown));
var title = markdownAndHeader.headerProps.title;
if(!title) {
title = premangledContent.find('h1').eq(0).text();
}
var pageClassName = 'page-' + pageKey;
var containerForPageContent = document.createElement('div');
containerForPageContent.className = 'bookmark-content ' + pageClassName;
if(markdownAndHeader.headerProps.title) {
var titleForPage = document.createElement('h0');
titleForPage.className = 'bookmark-content-title ' + pageClassName;
// Prepend the title to the main content section so it matches the style
// of content (indentation etc).
titleForPage.innerText = markdownAndHeader.headerProps.title;
containerForPageContent.appendChild(titleForPage);
if(markdownAndHeader.headerProps.subtitle) {
var subtitleForPage = document.createElement('p');
subtitleForPage.className = 'bookmark-content-subtitle';
containerForPageContent.appendChild(subtitleForPage);
subtitleForPage.innerText = markdownAndHeader.headerProps.subtitle;
}
}
containerForPageContent.appendChild(premangledContent[0]);
var menuBarForPage = document.createElement('div');
menuBarForPage.className = 'bookmark-menubar ' + pageClassName;
var premangledMenuForPage = document.createElement('div');
premangledMenuForPage.className = 'bookmark-menu section ' + pageClassName;
menuBarForPage.appendChild(premangledMenuForPage);
var nonBlankContent = $(premangledContent).find('>*');
var menu = Transformer.getMenu(runner, premangledContent)
Array.prototype.forEach.call(nonBlankContent, (itm) => containerForPageContent.appendChild(itm));
Array.prototype.forEach.call(MenuView(menu), (itm) => premangledMenuForPage.appendChild(itm));
Transformer.buttonize(containerForPageContent);
Transformer.smartquotes(containerForPageContent);
var hierarchicalDoc = hierarchize(containerForPageContent);
// Mangle content
Transformer.addIDsToHierarchicalDoc(runner, hierarchicalDoc, pageKey);
Transformer.mangle(runner, pageKey, hierarchicalDoc);
// It's mutated.
var mangledContentForPage = containerForPageContent;
return {
...pageData,
contentContainerNode: mangledContentForPage,
menuContainerNode: menuBarForPage,
hierarchicalDoc: hierarchicalDoc
};
}
runner.pageState = Flatdoc.mapPages(
runner.pageState,
function(data, pageKey) {
return appendExperience(pageKey, data);
}
);
runner.appendDocNodesToDom(runner.pageState);
runner.activatePageForCurrentUrl(runner.pageState);
};
Runner.prototype.appendDocNodesToDom = function(data) {
var contentRootNode = $('.bookmark-content-root')[0];
var append = function(data, _) {
contentRootNode.appendChild(data.contentContainerNode)
contentRootNode.appendChild(data.menuContainerNode)
};
Flatdoc.forEachPage(data, append, append);
};
Runner.prototype.activatePageForCurrentUrl = function(data) {
var dataForUrl = pageDataForUrl(window.location, data);
var toggleClasses = function(data, _) {
dataForUrl === data ?
data.contentContainerNode.classList.add("current") :
data.contentContainerNode.classList.remove("current");
dataForUrl === data ?
data.menuContainerNode.classList.add("current") :
data.menuContainerNode.classList.remove("current");
};
Flatdoc.forEachPage(data, toggleClasses, toggleClasses);
};
/**
* Fetches a given element from the DOM.
*
* Returns a jQuery object.
* @api private
*/
Runner.prototype.el = function(aspect) {
return $(this[aspect], document.body);
};
/*
* Helpers
*/
// http://stackoverflow.com/questions/298750/how-do-i-select-text-nodes-with-jquery
function getTextNodesIn(el) {
var exclude = 'iframe,pre,code';
return $(el).find(':not('+exclude+')').andSelf().contents().filter(function() {
return this.nodeType == 3 && $(this).closest(exclude).length === 0;
});
}
// http://www.leancrew.com/all-this/2010/11/smart-quotes-in-javascript/
function quotify(a) {
a = a.replace(/(^|[\-\u2014\s(\["])'/g, "$1\u2018"); // opening singles
a = a.replace(/'/g, "\u2019"); // closing singles & apostrophes
a = a.replace(/(^|[\-\u2014\/\[(\u2018\s])"/g, "$1\u201c"); // opening doubles
a = a.replace(/"/g, "\u201d"); // closing doubles
a = a.replace(/\.\.\./g, "\u2026"); // ellipses
a = a.replace(/--/g, "\u2014"); // em-dashes
return a;
}
})(jQuery);
/* jshint ignore:start */
/*!
* base64.js
* http://github.com/dankogai/js-base64
* THERE's A PROBLEM LOADING THIS in entrypoint mode.
*/
/**
* marked - a markdown parser
* Copyright (c) 2011-2020, Christopher Jeffrey. (MIT Licensed)
* https://github.com/markedjs/marked
*/
/*!
* node-parameterize 0.0.7
* https://github.com/fyalavuz/node-parameterize
* Exported as `Flatdoc.slugify`
*/
/* jshint ignore:end */
// This } is for the initial if() statement that bails out early.
}
================================================
FILE: docs/site/ORIGINS.md
================================================
Bookmark:
(A simple tool for editing and rendering Reason documentation)
Here's a list of all of the technologies that are used and included in Bookmark.
Each of these projects should include a LICENSE file from their original
project, but even if they do not, they still retain the license/copyright of
their original project (even though they are copied/"vendored" in
## Flatdoc:
This project is just a fork of flatdoc, so of course
[https://github.com/rstacruz/flatdoc](flatdoc) should be mentioned. Flatdoc is
excellent.
# jquery:
jquery is licensed under the MIT license, and is vendored in vendor/jquery.js
See its license [here](https://jquery.org/license/)
#medium-zoom
[Medium-zoom](https://github.com/francoischalifour/medium-zoom) is vendored as
well.
#Fira Mono Font
Is also vendored as the default source code font. See its LICENSE included in the vendor directory.
#Roboto Font
Is also vendored and is the default font for text. See its LICENSE included in the vendor directory.
# Stylus
The vendored stylus in `support/vendor/stylus.min.js` is gotten from
https://github.com/stylus/stylus/tree/client and is under MIT license (see the
repo).
# hljs
HLJS is vendored in support/vendor/ along with all of its out of the box css
styles. hljs is licensed under BSD 3-Clause License and the license can be
found in its repo [here](https://github.com/highlightjs/highlight.js).
# marked
Flatdoc vendors marked (markdown parsing library) inside of flatdoc.js
https://github.com/markedjs/marked
It is licensed under MIT (see the repo for license).
# Beach Images:
Credit Lance Aspser:
https://unsplash.com/photos/W785zpEXZZo
https://unsplash.com/photos/woDxDNvpmdk
================================================
FILE: docs/site/theme-white/theme.js
================================================
/*!
* Flatdoc - (c) 2013, 2014 Rico Sta. Cruz
* http://ricostacruz.com/flatdoc
* @license MIT
*/
(function($) {
var $window = $(window);
var $document = $(document);
/*
* If the hash is empty, we don't need to scroll to anything, and therefore
* we don't need to wait until images load to reveal the body (for size
* issues).
*/
$document.on('flatdoc:style-ready', function() {
window._bookmarkTimingStyleReady = Date.now();
if(!window.location.hash) {
document.body.style="visibility: visible";
}
});
/*
* Scrollspy.
*/
$document.on('flatdoc:ready', function() {
if (typeof mediumZoom !== 'undefined') {
mediumZoom(document.querySelectorAll('.bookmark-content img'), {
scrollOffset: 20,
container: document.body,
margin: 24,
background: '#ffffff',
});
document.querySelectorAll('.bookmark-content img').forEach(function(img) {
var parent = img.parentElement;
if (parent && parent.tagName.toUpperCase() === 'P') {
// Allows targeting css for containers of images
// since has() selector is not yet supported in css
parent.className += ' imageContainer';
}
});
}
});
})(jQuery);
/*! jQuery.scrollagent (c) 2012, Rico Sta. Cruz. MIT License.
* https://github.com/rstacruz/jquery-stuff/tree/master/scrollagent */
// Call $(...).scrollagent() with a callback function.
//
// The callback will be called everytime the focus changes.
//
// Example:
//
// $("h2").scrollagent(function(cid, pid, currentElement, previousElement) {
// if (pid) {
// $("[href='#"+pid+"']").removeClass('active');
// }
// if (cid) {
// $("[href='#"+cid+"']").addClass('active');
// }
// });
(function($) {
$.fn.scrollagent = function(options, callback) {
// Account for $.scrollspy(function)
if (typeof callback === 'undefined') {
callback = options;
options = {};
}
var $sections = $(this);
var $parent = options.parent || $(window);
// Find the top offsets of each section
var offsets = [];
$sections.each(function(i) {
var offset = $(this).attr('data-anchor-offset') ?
parseInt($(this).attr('data-anchor-offset'), 10) :
(options.offset || 0);
offsets.push({
id: $(this).attr('id'),
index: i,
el: this,
offset: offset
});
});
// State
var current = null;
var height = null;
var range = null;
// Save the height. Do this only whenever the window is resized so we don't
// recalculate often.
$(window).on('resize', function() {
height = $parent.height();
range = $(document).height();
});
// Find the current active section every scroll tick.
$parent.on('scroll', function() {
var y = $parent.scrollTop();
// y += height * (0.3 + 0.7 * Math.pow(y/range, 2));
var latest = null;
for (var i in offsets) {
if (offsets.hasOwnProperty(i)) {
var offset = offsets[i];
var el = offset.el;
var relToViewport = offset.el.getBoundingClientRect().top;
if(relToViewport > 0 && relToViewport < height / 2) {
latest = offset;
break;
}
}
}
if (latest && (!current || (latest.index !== current.index))) {
callback.call($sections,
latest ? latest.id : null,
current ? current.id : null,
latest ? latest.el : null,
current ? current.el : null);
current = latest;
}
});
$(window).trigger('resize');
$parent.trigger('scroll');
return this;
};
})(jQuery);
================================================
FILE: docs/site/theme-white/theme.styl.html
================================================
<meta charset="utf-8" vim: set filetype=Stylus: >
<script src="../Bookmark.js"> </script>
support-for-ie = true
$prim = #5674FF
$lowlight = #3f3e4d
$prim-1 = rgb(blend(rgba(#000000,.40) $prim))
$prim-2 = rgb(blend(rgba(#000000,.30) $prim))
$prim-3 = rgb(blend(rgba(#000000,.20) $prim))
$prim-4 = rgb(blend(rgba(#000000,.10) $prim))
$prim-5 = $prim
$prim-6 = rgb(blend(rgba(#FFFFFF,.10) $prim))
$prim-7 = rgb(blend(rgba(#FFFFFF,.20) $prim))
$prim-8 = rgb(blend(rgba(#FFFFFF,.30) $prim))
$prim-9 = rgb(blend(rgba(#FFFFFF,.40) $prim))
$prim-10 = rgb(blend(rgba(#FFFFFF,.50) $prim))
$prim-11 = rgb(blend(rgba(#FFFFFF,.60) $prim))
$prim-12 = rgb(blend(rgba(#FFFFFF,.68) $prim))
$prim-13 = rgb(blend(rgba(#FFFFFF,.78) $prim))
$prim-14 = rgb(blend(rgba(#FFFFFF,.86) $prim))
$prim-15 = rgb(blend(rgba(#FFFFFF,.91) $prim))
$prim-16 = rgb(blend(rgba(#FFFFFF,.95) $prim))
$prim-17 = rgb(blend(rgba(#FFFFFF,.98) $prim))
$prim-desat-1 = rgb(desaturate($prim-1, 50%))
$prim-desat-2 = rgb(desaturate($prim-2, 50%))
$prim-desat-3 = rgb(desaturate($prim-3, 50%))
$prim-desat-4 = rgb(desaturate($prim-4, 50%))
$prim-desat-5 = rgb(desaturate($prim-5, 50%))
$prim-desat = $prim-desat-5
$prim-desat-6 = rgb(desaturate($prim-6, 50%))
$prim-desat-7 = rgb(desaturate($prim-7, 50%))
$prim-desat-8 = rgb(desaturate($prim-8, 50%))
$prim-desat-9 = rgb(desaturate($prim-9, 50%))
$prim-desat-10 = rgb(desaturate($prim-10, 50%))
$prim-desat-11 = rgb(desaturate($prim-11, 50%))
$prim-desat-12 = rgb(desaturate($prim-12, 50%))
$prim-desat-13 = rgb(desaturate($prim-13, 50%))
$prim-desat-14 = rgb(desaturate($prim-14, 50%))
$prim-desat-15 = rgb(desaturate($prim-15, 50%))
$prim-desat-16 = rgb(desaturate($prim-16, 50%))
$prim-desat-17 = rgb(desaturate($prim-17, 50%))
$lowlight-1 = rgb(blend(rgba(#000000,.40) $lowlight))
$lowlight-2 = rgb(blend(rgba(#000000,.30) $lowlight))
$lowlight-3 = rgb(blend(rgba(#000000,.20) $lowlight))
$lowlight-4 = rgb(blend(rgba(#000000,.10) $lowlight))
$lowlight-5 = $lowlight
$lowlight-6 = rgb(blend(rgba(#FFFFFF,.10) $lowlight))
$lowlight-7 = rgb(blend(rgba(#FFFFFF,.20) $lowlight))
$lowlight-8 = rgb(blend(rgba(#FFFFFF,.30) $lowlight))
$lowlight-9 = rgb(blend(rgba(#FFFFFF,.40) $lowlight))
$lowlight-10 = rgb(blend(rgba(#FFFFFF,.50) $lowlight))
$lowlight-11 = rgb(blend(rgba(#FFFFFF,.60) $lowlight))
$lowlight-12 = rgb(blend(rgba(#FFFFFF,.68) $lowlight))
$lowlight-13 = rgb(blend(rgba(#FFFFFF,.78) $lowlight))
$lowlight-14 = rgb(blend(rgba(#FFFFFF,.86) $lowlight))
$lowlight-15 = rgb(blend(rgba(#FFFFFF,.91) $lowlight))
$lowlight-16 = rgb(blend(rgba(#FFFFFF,.95) $lowlight))
$lowlight-17 = rgb(blend(rgba(#FFFFFF,.98) $lowlight))
$lowlight-desat-1 = rgb(desaturate($lowlight-1, 50%))
$lowlight-desat-2 = rgb(desaturate($lowlight-2, 50%))
$lowlight-desat-3 = rgb(desaturate($lowlight-3, 50%))
$lowlight-desat-4 = rgb(desaturate($lowlight-4, 50%))
$lowlight-desat = rgb(desaturate($lowlight-5, 50%))
$lowlight-desat-5 = rgb(desaturate($lowlight-5, 50%))
$lowlight-desat-6 = rgb(desaturate($lowlight-6, 50%))
$lowlight-desat-7 = rgb(desaturate($lowlight-7, 50%))
$lowlight-desat-8 = rgb(desaturate($lowlight-8, 50%))
$lowlight-desat-9 = rgb(desaturate($lowlight-9, 50%))
$lowlight-desat-10 = rgb(desaturate($lowlight-10, 50%))
$lowlight-desat-11 = rgb(desaturate($lowlight-11, 50%))
$lowlight-desat-12 = rgb(desaturate($lowlight-12, 50%))
$lowlight-desat-13 = rgb(desaturate($lowlight-13, 50%))
$lowlight-desat-14 = rgb(desaturate($lowlight-14, 50%))
$lowlight-desat-15 = rgb(desaturate($lowlight-15, 50%))
$lowlight-desat-16 = rgb(desaturate($lowlight-16, 50%))
$lowlight-desat-17 = rgb(desaturate($lowlight-17, 50%))
.bg-prim-1
background-color: $prim-1
.bg-prim-2
background-color: $prim-2
.bg-prim-3
background-color: $prim-3
.bg-prim-4
background-color: $prim-4
.bg-prim,
.bg-prim-5
background-color: $prim-5
.bg-prim-6
background-color: $prim-6
.bg-prim-7
background-color: $prim-7
.bg-prim-8
background-color: $prim-8
.bg-prim-9
background-color: $prim-9
.bg-prim-10
background-color: $prim-10
.bg-prim-11
background-color: $prim-11
.bg-prim-12
background-color: $prim-12
.bg-prim-13
background-color: $prim-13
.bg-prim-14
background-color: $prim-14
.bg-prim-15
background-color: $prim-15
.bg-prim-16
background-color: $prim-16
.bg-prim-17
background-color: $prim-17
.bg-prim-desat-1
background-color: $prim-desat-1
.bg-prim-desat-2
background-color: $prim-desat-2
.bg-prim-desat-3
background-color: $prim-desat-3
.bg-prim-desat-4
background-color: $prim-desat-4
.bg-prim-desat-5,
.bg-prim-desat
background-color: $prim-desat
.bg-prim-desat-6
background-color: $prim-desat-6
.bg-prim-desat-7
background-color: $prim-desat-7
.bg-prim-desat-8
background-color: $prim-desat-8
.bg-prim-desat-9
background-color: $prim-desat-9
.bg-prim-desat-10
background-color: $prim-desat-10
.bg-prim-desat-11
background-color: $prim-desat-11
.bg-prim-desat-12
background-color: $prim-desat-12
.bg-prim-desat-13
background-color: $prim-desat-13
.bg-prim-desat-14
background-color: $prim-desat-14
.bg-prim-desat-15
background-color: $prim-desat-15
.bg-prim-desat-16
background-color: $prim-desat-16
.bg-prim-desat-17
background-color: $prim-desat-17
.bg-lowlight-1
background-color: $lowlight-1
.bg-lowlight-2
background-color: $lowlight-2
.bg-lowlight-3
background-color: $lowlight-3
.bg-lowlight-4
background-color: $lowlight-4
.bg-lowlight-5,
.bg-lowlight
background-color: $lowlight
.bg-lowlight-6
background-color: $lowlight-6
.bg-lowlight-7
background-color: $lowlight-7
.bg-lowlight-8
background-color: $lowlight-8
.bg-lowlight-9
background-color: $lowlight-9
.bg-lowlight-10
background-color: $lowlight-10
.bg-lowlight-11
background-color: $lowlight-11
.bg-lowlight-12
background-color: $lowlight-12
.bg-lowlight-13
background-color: $lowlight-13
.bg-lowlight-14
background-color: $lowlight-14
.bg-lowlight-15
background-color: $lowlight-15
.bg-lowlight-16
background-color: $lowlight-16
.bg-lowlight-17
background-color: $lowlight-17
.bg-lowlight-desat-1
background-color: $lowlight-desat-1
.bg-lowlight-desat-2
background-color: $lowlight-desat-2
.bg-lowlight-desat-3
background-color: $lowlight-desat-3
.bg-lowlight-desat-4
background-color: $lowlight-desat-4
.bg-lowlight-desat,
.bg-lowlight-desat-5
background-color: $lowlight-desat
.bg-lowlight-desat-6
background-color: $lowlight-desat-6
.bg-lowlight-desat-7
background-color: $lowlight-desat-7
.bg-lowlight-desat-8
background-color: $lowlight-desat-8
.bg-lowlight-desat-9
background-color: $lowlight-desat-9
.bg-lowlight-desat-10
background-color: $lowlight-desat-10
.bg-lowlight-desat-11
background-color: $lowlight-desat-11
.bg-lowlight-desat-12
background-color: $lowlight-desat-12
.bg-lowlight-desat-13
background-color: $lowlight-desat-13
.bg-lowlight-desat-14
background-color: $lowlight-desat-14
.bg-lowlight-desat-15
background-color: $lowlight-desat-15
.bg-lowlight-desat-16
background-color: $lowlight-desat-16
.bg-lowlight-desat-17
background-color: $lowlight-desat-17
.nodisplay
display: none
.mock-demo
padding: 20px
.mock-demo .swatch
justify-content: center
display:flex
background: white
padding: 10px
width: 100%
.mock-demo .color
display:flex
flex: 1
min-width: 20px
max-width: 700px
height: 40px
.mock-demo .swatch .button
margin-left: 30px
// Fonts
$body-font = PrivateWordFont, WordFont, Helvetica Neue, Open Sans, sans-serif
$mono-font = PrivateCodingFont, CodingFont, Menlo, monospace
$mono-font-size = 14px
// Line height has to be exact pixels, not in terms of em because bold segments
// of code have larger font size and their lines aren't consistently spaced.
// Noticable when switching code tabs.
$mono-line-height = 21px
$kbd-font-size = 0.80em
// Margins
$pad = 40px // Space between things
$sidepad = 16px // Padding to the left of the sidebar
$minipad = 20px // Space for mobile
$vmarginDouble = 32px // Margin between blocks
$vmargin = 16px // Margin between blocks
$vmarginHalf = 8px // Margin between blocks
$smallHeadingVMarginMobile = $vmargin
$smallHeadingVMarginTablet = $vmargin * 1.5
$smallHeadingVMarginDesktop = $vmargin * 2
// Colors
$gradedWhiteText = $prim-15
$gradedWhiteTextActive = $prim-16
$gradedHeaderbg = $lowlight-desat-17
$gradedHeaderbgDarker = $lowlight-desat-15
$gradedHeaderbgDarkest = $lowlight-desat-14
$gradedTitleLightfade = #fdfdff
$gradedTxtColor = $lowlight-desat-5
$gradedTxtColorLight = $lowlight-desat-6
$gradedTxtColorLighter = $lowlight-desat-8
$gradedTxtColorLightest = $lowlight-desat-10
$gradedLine = $lowlight-desat-14
$gradedHeaderTextShadow = 0 1px 2px #ffffffaa
$gradedCodebg = lighten($gradedHeaderbg, 30%)
$gradedCodeBorder = darken($gradedCodebg, 5%)
$gradedHeaderLinkColor = $gradedTxtColorLightest
/**
* The main colors in the theme.
*/
// $accent = #577fff * 0.85 // Alternative #5468ff (purply) or #577fff(blue)
$accent = #5674FF
$lowlight = #3f3e4d
$bigHeadPadTop = $pad * 1.5
$offwhite = #f8f8f8
/* $hitsbg = white */
$hitsbg = $prim-desat-15
$hitsBorderColor = $prim-desat-12
$hitsFontSize = 12px
$hitsLineHeight = 18px
$hitsCodeBg = $prim-desat-14
$hits-item-bg-cursor = $prim-desat-13
$hits-item-bg-cursor-double = $hits-item-bg-cursor
$hits-item-bg-hover = $prim-desat-14
$hits-item-border = $hitsbg
$hits-item-border-cursor = $hitsBorderColor
$grey = #909090
$txt = #444444
$txtlight = #888888
$line = #e8e8e8
// Header != "heading". Header is the sticky bar.
$headerPadding = 8px
$headerLinkColor = #909090
$headerLinkColorHover = #606060
$headerLinkColorCurrent = $accent
$headerLinkColorCurrentActive = darken($accent, 10%)
$headerbgactive = #f0f0f0
$header-height = 52px
$searchInputHeight = 28px
$searchInputIconWidth = 20px
$searchInputBg = #fff
$searchInputBorderColor = $hitsBorderColor
$searchInputBorderColorFocus = darken($searchInputBorderColor, 10%)
$button-txt-color=$gradedTxtColorLighter
$button-txt-color-focus-active=$gradedTxtColorLight
$button-bg = $lowlight-17
$button-border = $lowlight-13
$button-border-hover = $lowlight-13
$button-border-focus = $lowlight-12
$button-bg-hover = $lowlight-16
$button-bg-focus = $lowlight-16
$button-bg-active = $lowlight-15
$button-border-active = $lowlight-13
$button-prim-txt-color=$gradedWhiteText
$button-prim-txt-color-focus-active=white
$button-prim-bg = $prim
$button-prim-border = $prim-4
$button-prim-border-hover = $prim-3
$button-prim-border-focus = $prim-1
$button-prim-bg-hover = $prim-4
$button-prim-bg-focus = $prim-4
$button-prim-bg-active = $prim-3
$button-prim-border-active = $prim-2
// This could probably be derived from the others.
// It's the main right column
$rightcolumnwidth=380px
// Misc
$shadow-str = 0.1
// Dimensions
$sidebar-width = 300px
$content-width = 480px
// Because code blocks are rendered in search, need
// it to be about as wide as the standard right column
$rightdockedhitscolumnwidth = $rightcolumnwidth
$pre-width = 480px
$gradedBookSplitBg = $lowlight-desat-17
$gradedBookSplitShadow = darken($gradedBookSplitBg, 1%)
.medium-zoom-image
z-index:100
.medium-zoom-overlay
z-index:100
noselect()
-webkit-touch-callout: none; /* iOS Safari */
-webkit-user-select: none; /* Safari */
-khtml-user-select: none; /* Konqueror HTML */
-moz-user-select: none; /* Old versions of Firefox */
-ms-user-select: none; /* Internet Explorer/Edge */
user-select: none; /* Non-prefixed version, currently supported by Chrome, Edge, Opera and Firefox */
global-reset()
h0, h1, h2, h3, h4, h5, h6, p, blockquote, pre,
html, body, div, span, applet, object, iframe,
del, dfn, em, img, ins, kbd, q, s, samp,
dl, dt, dd, ol, ul, li,
a, small, abbr, acronym, address, big, cite, code, caption, tbody, table, tfoot, thead, tr, th, td,
fieldset, form, label, legend,
strike, strong, sub, sup, tt, var
font-weight: inherit
font-style: inherit
font-family: inherit
font-size: 100%
vertical-align: baseline
margin: 0
padding: 0
border: 0
outline: 0
body
/** Needed for medium-zoom positioning */
position:relative;
line-height: 1
color: black
background: white
ol, ul
list-style: none
table
border-spacing: 0
border-collapse: separate
vertical-align: middle
caption, th, td
text-align: left
vertical-align: middle
font-weight: normal
a img
border: none
*
-webkit-box-sizing: border-box
box-sizing: border-box
clearfix()
&:before
&:after
content: ""
display: table
&:after
clear: both
zoom: 1 if support-for-ie
// ----------------------------------------------------------------------------
// Mixins
scrollbar($bg=white)
&
-webkit-overflow-scrolling: touch
&::-webkit-scrollbar
width: 15px
height: 15px
&::-webkit-scrollbar-thumb
background: #ddd
border-radius: 8px
border: solid 4px $bg
&:hover::-webkit-scrollbar-thumb
background: #999
box-shadow: inset 2px 2px 3px rgba(0, 0, 0, 0.2)
antialias()
-webkit-font-smoothing: antialiased
text-rendering: optimizeLegibility
/* ----------------------------------------------------------------------------
* Base
*/
global-reset()
html
height: 100%
/* Messes up medium-zoom */
/* overflow-y:scroll */
/*
messes up medium-zoom
body
overflow-y:scroll
overflow-x:hidden
*/
/*
* jordwalke: Continues left parallel with a right docking, until the next
* right docking. Requires a JS shim at document load time to
* fix up the elements that occur before that next right docking,
* because there is no CSS selector for "comes before".
* What about using:
*
* The following selector matches <h1> elements only if they have a <p> element
* directly following them:
*
* h1:has(+ p)
*
* document.querySelectorAll(
* '.bookmark-content > img + pre,' +
* '.bookmark-content > img + blockquote,' +
* '.bookmark-content > p + pre,' +
* '.bookmark-content > p + blockquote,' +
* '.bookmark-content > ul + pre,' +
* '.bookmark-content > ul + blockquote,' +
* '.bookmark-content > ol + pre,' +
* '.bookmark-content > ol + blockquote,' +
* '.bookmark-content > h0 + pre,' +
* '.bookmark-content > h0 + blockquote,' +
* '.bookmark-content > h1 + pre,' +
* '.bookmark-content > h1 + blockquote,' +
* '.bookmark-content > h2 + pre,' +
* '.bookmark-content > h2 + blockquote,' +
* '.bookmark-content > h3 + pre,' +
* '.bookmark-content > h3 + blockquote,' +
* '.bookmark-content > h4 + pre,' +
* '.bookmark-content > h4 + blockquote,' +
* '.bookmark-content > h5 + pre,' +
* '.bookmark-content > h5 + blockquote,' +
* '.bookmark-content > h6 + pre,' +
* '.bookmark-content > h6 + blockquote,' +
* '.bookmark-content > table + pre,' +
* '.bookmark-content > table + blockquote'
* ).forEach(function(e) {e.previousSibling ? (e.previousSibling.style="clear:both") : null;})
*/
continueRight
clear:left
float:left
html
overflow-x: hidden
body, td, textarea, input
font-family: $body-font
line-height: 1.6
font-size: 16px
color:$gradedTxtColor
@media (max-width: 480px) /* Mobile */
font-size: 12px
a
color: $accent
text-decoration: none
&:hover, &:focus
color: $accent * 0.8
&:focus
text-decoration: underline
/* ----------------------------------------------------------------------------
* Content styling
*/
.bookmark-content
img
margin: 0
.imageContainer
margin: $vmargin 0
p, ul, ol, h0, h1, h2, h3, h4, h5, h6, pre, blockquote, dl, codetabscontainer
padding: $vmarginHalf 0
blockquote
padding: $vmargin 0
dd
padding-left: 0.5 * $pad
margin-bottom: $vmargin
dt
font-size: 1.1em
font-weight: bold
padding: $vmarginHalf 0
h0, h1, h2, h3, h4, h5, h6
font-weight: bold
antialias()
pre
font-family: $mono-font
font-size: $mono-font-size
line-height: $mono-line-height
ul > li
list-style-type: disc
ol > li
list-style-type: decimal
ul, ol
margin-left: 20px
/* jordwalke: This margin-right is needed to allow lists to "dock" to the
* left of a right block that spans multiple left blocks. The padding-right
* is needed regardless to get the right boundary of text to be a perfect box.
* TODO: This is the source of funny body size in mobile dimensions.
*/
margin-right: -20px
ul > li
list-style-type: none
position: relative
&:before
content: ''
display: block
position: absolute
left: -17px
top: 7px
width: 4px
height: 4px
border-radius: 4px
background: white
border: solid 1px $grey
li > :first-child
padding-top: 0
strong, b
font-weight: bold
i, em
font-style: italic
/*color: $grey*/
dd > code,
p > code
background: $gradedCodebg
border-radius: 2px;
border: 1px solid $gradedCodeBorder
kbd
user-select: none
font-family: $mono-font
font-size: $kbd-font-size
background: white
border-radius: 3px;
border-top: 1px solid darken($gradedCodeBorder, 5%)
border-right: 2px solid darken($gradedCodeBorder, 5%)
border-left: 2px solid darken($gradedCodeBorder, 5%)
border-bottom: 3px solid darken($gradedCodeBorder, 7%)
padding-left: 4px;
padding-right: 4px;
padding-top: 1px;
padding-bottom: 2px;
cursor: pointer;
kbd:active
position:relative
top: 2px
border-bottom: 2px solid darken($gradedCodeBorder, 5%)
table > code, li > code, tr > code, td > code, th > code
background: $gradedCodebg
border-radius: 2px;
border: 1px solid $gradedCodeBorder
// Inline code with backticks
code
font-family: $mono-font
padding: 1px 3px
font-size: $mono-font-size
dl > dt > code, h0 code, h1 code, h2 code, h3 code, h4 code, h5 code, h6 code
padding: 0px
font-size: 1em
pre > code
// But for tripple backticks we reset the padding.
// Most of the padding will occur on the outside pre, not code element
// when in literate mode, or in non-literate mode it wil need to be something
// different. And for code tabs it will need to be something different still,
// to make room for the tabs
padding: 0px
border: none;
background: $gradedCodebg
display: block
background: transparent
font-size: 0.90em
letter-spacing: 0px
blockquote
:first-child
padding-top: 0
:last-child
padding-bottom: 0
table
margin-top: $vmargin
margin-bottom: $vmargin
padding: 0
border-collapse: collapse
/* Tables in non split mode should not have any clearing */
/* clear: both */
/* float: left */
tbody
> :nth-child(2n)
background-color: $offwhite
tr
border-top: 1px solid $gradedLine
background-color: white
margin: 0
padding: 0
th
background-color: $offwhite
text-align: auto;
font-weight: bold
border: 1px solid $gradedLine
margin: 0
padding: 6px 13px
td
text-align: auto;
border: 1px solid $gradedLine
margin: 0
padding: 6px 13px
th, td
:first-child
margin-top: 0;
:last-child
margin-bottom: 0;
/* ----------------------------------------------------------------------------
* Content
*/
.bookmark-content-root
min-height: 90%
position: relative
/*
* https://caniuse.com/#search=scroll-margin-top
*
scroll-margin-top: $header-height
*/
/* Shadow around image in literate right bar */
/* Remove outline while animating open */
/* It's still not enough to hide outline while closing */
.medium-zoom--opened
.bookmark-content
.imageContainer
&:after
box-shadow: none !important
@media (min-width: 1280px) /* Big desktop */
body:not(.no-literate)
.bookmark-content
blockquote
.imageContainer
/* So clicks pass through to image */
pointer-events: none
overflow:hidden;
display:inline-block;
position:relative;
border-radius:0px;
&:after
content: "";
position: absolute;
width: 100%; height: 100%;
left: 0; top: 0;
box-shadow: inset 0px 0px 0px 0.5px #55555511
img
vertical-align:middle;
/* Reenable pointer events */
pointer-events: auto
.bookmark-content.current
display: inherit;
.bookmark-content
display: none;
padding-top: $pad - $vmargin
padding-bottom: $pad
padding-left: $pad
padding-right: $pad
clearfix()
img
width: 100%
max-width: 700px
blockquote
color: $gradedTxtColorLighter
padding-left: 40px
h0, h1, h2, h3, h4, h5, h6
antialias()
font-family: $body-font
padding-bottom: $vmarginHalf
// Headers have an extra big margin above their padding effectively making the total
// space double.
margin-top: $vmargin
h0 + p, h0 + ul, h0 + ol,
h1 + p, h1 + ul, h1 + ol,
h2 + p, h2 + ul, h2 + ol,
h3 + p, h3 + ul, h3 + ol,
h4 + p, h4 + ul, h4 + ol,
h5 + p, h5 + ul, h5 + ol,
h6 + p, h6 + ul, h6 + ol
padding-top: $vmarginHalf // Half because headers have the other half but this was already the default. This rule isn't needed
h0, h1, h2
letter-spacing: 1px
font-size: 1.5em
h0
font-size: 2em
// The subtitle that is injected from headerProps
p.bookmark-content-subtitle
font-size: .6em;
font-weight: normal;
color: $gradedTxtColorLighter
padding-top: 0
padding-bottom: 0
h3
font-size: 1.2em
// Lines
h0, h1, h2, .big-heading
padding-top: $bigHeadPadTop
&:before
display: block
content: ''
background: linear-gradient(left, rgba(#ff0000, 1.0) 0%, rgba($gradedLine, 0.0) 80%)
box-shadow: 0 1px 0 rgba(white, 0.4)
height: 1px
position: relative
top: $pad * -1
left: $pad * -1
@media (max-width: 768px) /* Mobile and tablet */
padding-top: $minipad * 2
&:before
background: $gradedLine
left: $pad * -1
top: $minipad * -1
width: 120%
/* Small headings */
h4, h5, h6, .small-heading
/* border-bottom: solid 1px rgba(black, 0.07) */
color: $gradedTxtColorLighter
padding-top: $vmarginHalf
padding-bottom: $vmarginHalf
body:not(.big-h3) & h3
@extends .bookmark-content .small-heading
font-size: 0.9em
body.big-h3 & h3
@extends .bookmark-content .big-heading
h0:first-child,
h1:first-child
padding-top: 0
&, a, a:visited
color: $gradedTxtColor
&:before
display: none
@media (max-width: 768px) /* Tablet */
.bookmark-content
h4, h5, h6, .small-heading, body:not(.big-h3) & h3
padding-top: $smallHeadingVMarginTablet
padding-bottom: $smallHeadingVMarginTablet
@media (max-width: 480px) /* Mobile */
.bookmark-content
padding: $minipad
padding-top: $minipad * 2
h4, h5, h6, .small-heading, body:not(.big-h3) & h3
padding-top: $smallHeadingVMarginMobile
padding-bottom: $smallHeadingVMarginMobile
// ----------------------------------------------------------------------------
// Code blocks
// Omits rounded corners at top to make room for the tab selection.
inset-box-codetabs-container()
/* border: solid 1px $offwhite*0.95 */
/* border-top: solid 1px $offwhite*0.9 */
/* border-left: solid 1px $offwhite*0.93 */
display: block
padding: $vmargin
background: $gradedCodebg
overflow: auto
scrollbar($gradedCodebg)
border-radius-bottom: 2px
inset-box()
inset-box-codetabs-container()
border-radius-top: 2px
body.no-literate .bookmark-content > pre > code
inset-box()
@media (max-width: 1280px) /* Small desktop */
.bookmark-content > pre > code
inset-box()
/* Hide scrollbar but keep functionality */
pre > code
&::-webkit-scrollbar
display: none
/* Hide scrollbar for IE, Edge and Firefox */
pre > code
overflow-x:scroll
-ms-overflow-style: none /* IE and Edge */
scrollbar-width: none /* Firefox */
currentCodeTabButton()
color: $headerLinkColorCurrent
border-bottom: 2px solid $headerLinkColorCurrent
&:active
color: $headerLinkColorCurrentActive
.bookmark-content > codetabscontainer
/* Last child is the tab switcher itself */
font-weight: bold
display:flex
color: $gradedTxtColorLightest
overflow: hidden
padding-bottom: 0
codetabbutton
text-align: center
min-width: 30px
user-select: none
margin-right: 20px
cursor: pointer;
font-size: 14px
border-bottom: 2px solid transparent
&:active, &:hover
color: $gradedTxtColorLighter
/**
* Hide all of the code that comes after a codetabs container
* by default. We will selectively display them based on active tab.
*/
.bookmark-content > codetabscontainer.bookmark-codetabs-length1
&+ pre
display: none
.bookmark-content > codetabscontainer.bookmark-codetabs-length2
&+ pre,
&+ pre + pre
display: none
.bookmark-content > codetabscontainer.bookmark-codetabs-length3
&+ pre,
&+ pre + pre,
&+ pre + pre + pre
display: none
.bookmark-content > codetabscontainer.bookmark-codetabs-length4
&+ pre,
&+ pre + pre,
&+ pre + pre + pre,
&+ pre + pre + pre + pre
display: none
.bookmark-content > codetabscontainer.bookmark-codetabs-length5
&+ pre,
&+ pre + pre,
&+ pre + pre + pre,
&+ pre + pre + pre + pre,
&+ pre + pre + pre + pre + pre
display: none
/**
* Selectively enable the visibility of following pre/code sections depending
* on which tab is active.
*/
.bookmark-content > codetabscontainer.bookmark-codetabs-active1
& + pre
display: block
> codetabbutton:nth-child(1)
currentCodeTabButton()
.bookmark-content > codetabscontainer.bookmark-codetabs-active2
& + pre + pre
display: block
> codetabbutton:nth-child(2)
currentCodeTabButton()
.bookmark-content > codetabscontainer.bookmark-codetabs-active3
& + pre + pre + pre
display: block
> codetabbutton:nth-child(3)
currentCodeTabButton()
.bookmark-content > codetabscontainer.bookmark-codetabs-active4
& + pre + pre + pre + pre
display: block
> codetabbutton:nth-child(4)
currentCodeTabButton()
.bookmark-content > codetabscontainer.bookmark-codetabs-active5
& + pre + pre + pre + pre + pre
display: block
> codetabbutton:nth-child(5)
currentCodeTabButton()
/**
* Formatting for grey boxes under code tabs.
*/
insetCodeTabCodes()
codetabscontainer.bookmark-codetabs-active1
& + pre > code
inset-box-codetabs-container()
codetabscontainer.bookmark-codetabs-active2
& + pre + pre > code
inset-box-codetabs-container()
codetabscontainer.bookmark-codetabs-active3
& + pre + pre + pre > code
inset-box-codetabs-container()
codetabscontainer.bookmark-codetabs-active4
& + pre + pre + pre + pre > code
inset-box-codetabs-container()
codetabscontainer.bookmark-codetabs-active5
& + pre + pre + pre + pre + pre > code
inset-box-codetabs-container()
@media (max-width: 1280px)
body .bookmark-content
insetCodeTabCodes()
@media (min-width: 1280px) /* Big desktop */
body.no-literate .bookmark-content
insetCodeTabCodes()
// ----------------------------------------------------------------------------
// Buttons
.button.prim
&, &:visited
background: $button-prim-bg
color: $button-prim-txt-color
border: solid 1px $button-prim-border
&:hover
border-color: $button-prim-border-hover
background: $button-prim-bg-hover
&:focus
border-color: $button-prim-border-focus
background: $button-prim-bg-focus
color: $button-prim-txt-color-focus-active
&:active
border-color: $button-prim-border-active
background-color: $button-prim-bg-active
color: $button-prim-txt-color-focus-active
.button
antialias()
transition-property: color, box-shadow, background, border-color
transition: 32ms ease-in 0s
/* box-shadow: inset rgba(255,255,255, .05) 0px 3px 0 -2px, rgba(0,0,0,0.018) 0px 2px 1px */
box-shadow: rgba(0,0,0,0.018) 0px 2px 1px
noselect()
cursor: pointer;
font-family: $body-font
letter-spacing: 0px
font-weight: bold
display: inline-block
padding: 0px 16px
font-size: .9em
border: solid 1px $button-border
border-radius: 1px
margin: 0px
&, &:visited
background: $button-bg
color: $button-txt-color
text-shadow: none
&:hover, &:focus
text-decoration: none
&:hover
border-color: $button-border-hover
background: $button-bg-hover
&:focus
/* box-shadow: inset rgba(255,255,255, .05) 0px 3px 0 -2px, rgba(0,0,0,0.03) 0px 2px 1px */
box-shadow: rgba(0,0,0,0.03) 0px 2px 1px
text-decoration: none;
border-color: $button-border-focus
color: $button-txt-color-focus-active
background: $button-bg-focus
&:active
transition: transform 60ms ease-out 0s;
text-decoration: none;
border-color: $button-border-active
background-color: $button-bg-active
box-shadow: none;
color: $button-txt-color-focus-active
.bookmark-content
.button + em
color: $gradedTxtColorLighter
// ----------------------------------------------------------------------------
// Literate mode content
@media (min-width: 1280px) /* Big desktop */
body:not(.no-literate)
.bookmark-content-root
background-color: $offwhite
$w = ($sidebar-width + $content-width)
/* Shadow on the book split */
background: linear-gradient(90deg, transparent 776px, $gradedBookSplitShadow 776px, $gradedBookSplitBg 782px);
&:before
background-color: $gradedLine
content: "";
display: block;
width: 1px;
height: 100%;
position: absolute;
z-index: 0;
top: 0;
left: 776px; /* Can actually ues a calc to get stretchy split calc(50% - 1px); */
// Literate mode
@media (min-width: 1280px) /* Big desktop */
small-heading()
margin-left: $pad
width: $content-width - $pad * 2
padding-left: 0
padding-right: 0
body:not(.no-literate)
.bookmark-content
padding-left: 0
padding-right: 0
width: $content-width + $pre-width
max-width: none
>
.bookmark-synced-up-left
clear: both
/*.bookmark-synced-up-right
margin-top:$pad */
p, ul, ol, h0, h1, h2, h3, h4, h5, h6, pre, blockquote, dl, dt, dd
width: $content-width
padding-right: $pad
padding-left: $pad
codetabscontainer, pre, blockquote
width: $pre-width
padding-left: ($pad/2)
padding-right: ($pad/2)
float: right
clear: right
+
p, ul, ol
clear: both
p, ul, ol
float: left
clear: left
/* Allow content to float to the right of smaller headers, but then we need to adjust
* for the extra padding in headers in the items that are floated to the right of them
* We match the padding-tops of those floated items that appear right after a small
* header that is floated left.
* small header top-paddings only have three ranges:
* $smallHeadingVMarginDesktop : Over 768px wide viewport
* $smallHeadingVMarginTablet : Over 480px wide viewport but under 768px.
* $smallHeadingVMarginMobile : Under 480px wide viewport
*
* But the floating behavior only even applies for ultra-wide (min-width: 1280px)
* So we only need to apply the extra padding to the top of content floated
* right, immediately after a small header which is marked as floating left.
* EDIT: Actually, we'll just make padding-top: vmarginHalf for
* small headers, like they're any other piece of content. This special
* case of + pre/blockquote isn't needed now.
* clear: both will cause the left column to "sync up"
*/
h0, h1, h2, h3, h4, h5, h6, .small-heading, body:not(.big-h3) & h3
float: left
clear: both
h0 + pre,
h0 + codetabscontainer,
h0 + blockquote,
h1 + pre,
h1 + codetabscontainer,
h1 + blockquote,
h2 + pre,
h2 + codetabscontainer,
h2 + blockquote,
h3 + pre,
h3 + codetabscontainer,
h3 + blockquote
padding-top: $bigHeadPadTop
margin-top: $vmargin
h4 + pre,
h4 + codetabscontainer,
h4 + blockquote,
h5 + pre,
h5 + codetabscontainer,
h5 + blockquote,
h6 + pre,
h6 + codetabscontainer,
h6 + blockquote,
.small-heading + pre,
.small-heading + codetabscontainer,
.small-heading + blockquote,
/* border-bottom: solid 1px rgba(black, 0.07) */
margin-top: $vmargin
h4, h5, h6, .small-heading, body:not(.big-h3) & h3
small-heading()
table
/* jordwalke: Moved the clearing only to here instead of the general table rule.
* Otherwise, the following layout is messed up when resizing the window to be narrow:
*
* `type Unix.error`
* : Error codes for specific `Unix` module errors.
*
* Value | Meaning
* :------------------- |:------------------------------------------
* `EACCES` | Permission denied
* `EAGAIN` | Resource temporarily unavailable; try again
* `EBADF` | Bad file descriptor
* `EBUSY` | Resource unavailable
* `EEXISTS` | File already exists
* `EISDIR` | Is a directory
* `ENOENT` | No such file or directory
* `ENOTDIR` | Not a directory
* `ENOTEMPTY` | Directory not empty
* [See all](https://caml.inria.fr/pub/docs/manual-ocaml/libref/Unix.html#TYPEerror) |
*
*
* `fun Unix.dup` : `(~cloexec:bool=?, ` `file_descr` `) => ` `file_descr`
* : Return a new file descriptor referencing the same file as the given
* descriptor. See `Unix.set_close_on_exec` for documentation on the `cloexec`
* optional argument.
* (Copied from stdlib docs)
*/
clear: left
float: left
margin-left: $pad
margin-right: $pad
max-width: $content-width - $pad*2
body:not(.no-literate):not(.big-h3)
.bookmark-content > h3
small-heading()
// ----------------------------------------------------------------------------
// Header
.medium-zoom--opened > .bookmark-header
/* Needs to be less than medium-zoom overlays */
z-index:50
.bookmark-header
display:flex
flex-direction: column
z-index:101
/* text-shadow: 0 1px 0 rgba(white, 0.5) */
position: -webkit-sticky
position: sticky
line-height: 20px;
top: 0px;
/**
* Search UI.
*/
@media (max-width: 768px) {
.bookmark-menubar {
display: none;
}
}
.bookmark-header {
height: 52px;
/* Total header height should be 52 = vmargin*2 + line-height(20) */
/* Total header height should be 52 = vmargin*2 + line-height(20) */
}
.bookmark-header .bookmark-search-form {
align-items: center;
position: relative;
width: 100%;
display: flex;
line-height: 100%;
z-index: 0;
padding-left:$headerPadding
padding-right:$headerPadding
}
$searchPillHorizontalMargin = 6px
$searchPillMargin = 5px
$searchPillHorzPadding = 6px
$searchPillBorderSize = 1px
// The search icon, or "version:" pill when in version search mode.
$leftPillWidth = 55px;
/* An extra minus two at the end for border */
$searchPillHeight = $searchInputHeight - 2 * $searchPillMargin
pillColor()
background-color: $hitsBg;
border: $searchPillBorderSize solid $hitsBorderColor;
color: $gradedTxtColorLightest
searchPillDimensions()
height: $searchPillHeight
font-size: 12px
line-height: $searchPillHeight
font-size: 12px
text-align: center;
box-sizing:border-box
$leftSearchIconPillWidth = 20px
.bookmark-header .bookmark-search-form.mode-version-selector:before {
border-radius: 0.5 * $searchPillHeight
searchPillDimensions()
position: absolute;
pillColor()
padding-left: $searchPillHorzPadding;
padding-right: $searchPillHorzPadding;
content: "version:";
width: $leftPillWidth;
margin-left: $searchPillMargin;
}
.bookmark-header .bookmark-search-form:before {
content: " ⚲ ";
searchPillDimensions()
/* Square */
width: $searchPillHeight
position: absolute;
padding-left: $searchPillHorzPadding;
padding-right: $searchPillHorzPadding;
width: $leftSearchIconPillWidth
margin-left: $searchPillMargin;
/* Does not render correctly in Chrome MacOS for some reason */
/* font-weight: bold */
font-size: 18px
color: $gradedTxtColorLightest
transform: rotate(-45deg) translateY(2px)
z-index: 1
}
$availableHeaderSpaceAboveSearchHits = $sidebar-width - 2*$headerPadding
$searchInputUnfocusedWidth = .8 * $availableHeaderSpaceAboveSearchHits
.bookmark-header .bookmark-search-input {
// Padding for search icon and close button
position: absolute;
right: 0px;
padding-right: 20px;
border:1px solid $searchInputBorderColor;
border-radius: $searchInputHeight;
background-color: $searchInputBg;
color: $gradedTxtColor
position: relative;
width: $searchInputUnfocusedWidth
transition: width 220ms ease-in-out 0s, border-color 220ms ease-in-out 0s
height: $searchInputHeight;
display: flex;
line-height: 100%;
z-index: 0;
font-size: 12px
}
.bookmark-header .bookmark-search-input {
padding-left: $leftSearchIconPillWidth + $searchPillHorzPadding + $searchPillHorzPadding
}
.bookmark-header .bookmark-search-form.mode-version-selector .bookmark-search-input {
padding-left: $leftPillWidth + $searchPillHorzPadding + $searchPillHorzPadding
transform: none
}
/**
* Keep the input expanded even if they blur, if they have entered text.
*/
.bookmark-header .bookmark-search-input:valid,
.bookmark-header .bookmark-search-input:focus {
/* z-index: 1; */
outline-style: none;
box-shadow: none;
outline: none;
// Make it take up the whole sidebar width (when taking into account the padding)
/* width: $availableHeaderSpaceAboveSearchHits */
}
.bookmark-header .bookmark-search-input:focus {
/* Make it match the hits border color when focused */
border:1px solid $searchInputBorderColorFocus
}
.bookmark-header .bookmark-search-input::-webkit-input-placeholder
color: $gradedTxtColorLightest
.bookmark-header .bookmark-search-input::-ms-input-placeholder
color: $gradedTxtColorLightest
.bookmark-header .bookmark-search-input::placeholder
color: $gradedTxtColorLightest
.bookmark-search-input:before {
border: 3px solid #e5e5e5;
border-radius: 50%;
content: " ";
display: block;
height: 6px;
left: 15px;
position: relative;
top: 50%;
-webkit-transform: translateY(-58%);
transform: translateY(-58%);
width: 6px;
z-index: 1
}
.bookmark-search-input:after {
background: #e5e5e5;
content: " ";
height: 7px;
left: 24px;
position: relative;
top: 55%;
-webkit-transform: rotate(-45deg);
transform: rotate(-45deg);
width: 3px;
z-index: 1
}
.bookmark-header .bookmark-dropdown-button
border: none
color: $gradedTxtColorLightest
margin-left: 8px
height: $searchPillHeight
background-color: transparent;
display: inline-block;
vertical-align: middle;
outline: 0;
cursor: pointer;
width:0
padding:0
.bookmark-header .bookmark-search-input-right-reset-icon {
searchPillDimensions()
/* Square */
width: $searchPillHeight
/* Unstyle the original button */
border: none
position: relative;
height: $searchPillHeight
background-color: transparent;
display: inline-block;
vertical-align: middle;
outline: 0;
cursor: pointer;
width:0
padding:0
}
$closeIconDiameter = 14px
/**
* The / icon to indicate / can focus search.
*/
.bookmark-header .bookmark-search-input-right-reset-icon:before
searchPillDimensions()
/* Square */
width: $searchPillHeight
position:absolute
top: 0px
left: 0px
left: 0 - $searchPillMargin - $searchPillHeight - 1px
content: "/";
pillColor()
border-radius: 5px
pointer-events: none
transition: opacity 100ms
opacity: 0
.bookmark-header .bookmark-search-input:not(:valid):focus ~ .bookmark-search-input-right-reset-icon:before,
.bookmark-header .bookmark-search-input:not(:valid):not(:focus) ~ .bookmark-search-input-right-reset-icon:before {
opacity: .7
}
/**
* The close icon when there is content in the box.
*/
.bookmark-header .bookmark-search-input-right-reset-icon:after
searchPillDimensions()
/* Square */
width: $searchPillHeight
position:absolute
top: 0px
left: 0px
content: "\00d7";
left: 0 - $searchPillMargin - $searchPillHeight - 1px
transition: opacity 100ms
opacity: 0
.bookmark-header .bookmark-search-input:valid ~ .bookmark-search-input-right-reset-icon:after {
opacity: .7
}
.bookmark-header .bookmark-version-menu
transition: color 100ms
font-weight:bold
margin-left: $searchPillHorzPadding
searchPillDimensions()
color: $gradedTxtColorLightest
outline: none
border: 0
-moz-appearance: none;
-webkit-appearance: none
padding: 0;
border: none;
background: none;
.bookmark-header .bookmark-version-menu:hover,
.bookmark-header .bookmark-version-menu:focus
border:none
color: $headerLinkColorHover
.bookmark-header .bookmark-version-menu:after
text-decoration: none
searchPillDimensions()
font-size:14px
content: '▾'
@media (min-width: 500px) {
.bookmark-hits-scroll {
width: $sidebar-width
}
}
@media (max-width: 500px) {
.bookmark-hits-scroll {
width: 100%;
}
}
.bookmark-hits-noresults-list {
display: flex;
justify-content: center;
margin-top: 30vh;
font-size: 20px;
color: $gradedTxtColorLightest
text-align: center
}
.bookmark-hits-scroll.bookmark-hits-scroll-hidden {
/* Hide the box shadow so it doesn't bleed into the view */
box-shadow: none
transition: all 0s ease-in-out
transform-origin: center top
transform: scale(0.95) /* translateX(100%) */
opacity:0
visibility:hidden
}
.bookmark-hits-scroll {
border-right: 1px solid $hitsBorderColor
box-shadow: 0 2px 15px 0 rgba(0,0,0,0.05);
/* transform: translateX(0px); */
transition: all 0s ease-in-out
/* Make it be as big as the viewport minus header height */
/* Keep this in sync with the $header-height (can't use dollar in calc with stylus) */
height: calc(100vh - 52px);
position: absolute;
top: 0px;
left: 0px;
bottom: 0px;
z-index: 2;
overflow-x: scroll;
-ms-overflow-style: none /* IE and Edge */;
scrollbar-width: none /* Firefox */;
line-height: 20px !important;
font-size: 14px !important;
background-color: $hitsbg
// color: $gradedTxtColor
color: $gradedTxtColor
line-height: 20px !important;
font-size: 14px !important;
overflow: auto;
/* Bottom: 100% makes it grow upwards */
/* Total header height should be 52 = vmargin*2 + line-height(20) */
/* Minus one because of the top border of the header doesn't count for top */
-webkit-overflow-scrolling: touch;
}
.bookmark-hits-scroll::-webkit-scrollbar {
display: none;
}
.bookmark-in-doc-highlight {
background-color: rgba(255,241,168,0.333);
transition: background-color .2s ease-out .2s;
background-clip: content-box
}
pre.bookmark-in-doc-highlight {
background-clip: border-box
}
.bookmark-hits-scroll::-webkit-scrollbar {
width: 15px;
height: 15px;
}
.bookmark-hits-scroll::-webkit-scrollbar-thumb {
background: #ddd;
border-radius: 8px;
border: solid 4px #f8f8f8;
}
.bookmark-hits-scroll:hover::-webkit-scrollbar-thumb {
background: #999;
box-shadow: inset 2px 2px 3px rgba(0,0,0,0.2);
}
.bookmark-hits-scroll .bookmark-hits-list {
flex-wrap: nowrap;
flex-direction: column;
margin: 0;
border-top: none;
font-size: $hitsFontSize
line-height: $hitsLineHeight
}
.bookmark-hits-scroll .bookmark-hits-item {
cursor: pointer;
transition: border-color 0ms ease-out 0s, background-color 0ms ease-out 0s;
border-top: 1px solid $hits-item-border;
padding: $vmargin
border-bottom:1px solid $hits-item-border;
/* By default is: */
/* width: calc(25% - 1rem) */
width: 100%;
margin: 0;
box-shadow: none;
}
.bookmark-hits-scroll .bookmark-hits-item:hover
transition: border-color 50ms ease-out 0s, background-color 50ms ease-out 0s;
background-color: $hits-item-bg-hover
border-top: 1px solid $hits-item-bg-hover
border-bottom: 1px solid $hits-item-bg-hover
.bookmark-hits-scroll .bookmark-hits-item.cursor
background-color: $hits-item-bg-cursor
.bookmark-hits-scroll .bookmark-hits-item.cursor
border-top: 1px solid $hits-item-border-cursor
border-bottom: 1px solid $hits-item-border-cursor
.bookmark-hits-scroll .bookmark-hits-item:first-child,
.bookmark-hits-scroll .bookmark-hits-item.cursor:first-child,
.bookmark-hits-scroll .bookmark-hits-item:hover:first-child
border-top:none
.bookmark-hits-scroll .bookmark-hits-item:active,
.bookmark-hits-scroll .bookmark-hits-item.cursor:hover
background-color: $hits-item-bg-cursor-double
/* border-left: 1px solid darken($hits-item-bg-cursor-double, 2%) */
.bookmark-hits-scroll .bookmark-hits-item:active .bookmark-hits-item-button-contents {
user-select: none;
transition: transform 60ms ease-out 0s;
transform: scale(0.98);
}
.bookmark-hits-scroll .bookmark-hits-item-button-contents a {
pointer-events: none
}
.bookmark-hits-scroll .bookmark-hits-item .bookmark-hits-item-button-contents {
opacity: 0.9
transform: scale(1);
transition: transform 0.05s ease-out 0s
}
.bookmark-hits-scroll .bookmark-hits-item li {
list-style-type: none;
position: relative;
margin-left: 2px;
}
.bookmark-hits-scroll .bookmark-hits-item h0,
.bookmark-hits-scroll .bookmark-hits-item h1,
.bookmark-hits-scroll .bookmark-hits-item h2,
.bookmark-hits-scroll .bookmark-hits-item h3,
.bookmark-hits-scroll .bookmark-hits-item h4,
.bookmark-hits-scroll .bookmark-hits-item h5
font-weight:bold
.bookmark-hits-scroll .bookmark-hits-item
strong, b
font-weight: 500 // Don't want to overshadow the crumb boldness so temper this.
.bookmark-hits-scroll .bookmark-hits-item li:before {
content: '';
display: block;
position: absolute;
left: -11px;
top: 7px;
width: 2px;
height: 2px;
border-radius: 2px;
background: transparent;
border: solid 1px #ccc;
}
/* Minikeys */
.bookmark-hits-scroll .bookmark-hits-item kbd
user-select: none
font-family: $mono-font
font-size: $kbd-font-size
background: white
border-radius: 3px;
border-top: 1px solid darken($gradedCodeBorder, 5%)
border-right: 2px solid darken($gradedCodeBorder, 5%)
border-left: 2px solid darken($gradedCodeBorder, 5%)
border-bottom: 3px solid darken($gradedCodeBorder, 7%)
padding-left: 4px;
padding-right: 4px;
padding-top: 1px;
padding-bottom: 2px;
cursor: pointer;
.bookmark-hits-scroll .bookmark-hits-item table > code,
.bookmark-hits-scroll .bookmark-hits-item li > code,
.bookmark-hits-scroll .bookmark-hits-item tr > code,
.bookmark-hits-scroll .bookmark-hits-item td > code,
.bookmark-hits-scroll .bookmark-hits-item th > code,
.bookmark-hits-scroll .bookmark-hits-item p > code {
font-family: $mono-font
font-size: 0.9em;
background: $hitsCodeBg
border: 1px solid darken($hitsCodeBg, 7%)
border-radius: 2px;
padding: 1px 3px;
}
.bookmark-hits-scroll .bookmark-hits-item pre {
font-family: $mono-font;
background: $hitsCodeBg
display: block;
padding: 10px;
border-radius: 2px;
overflow-x: scroll;
-ms-overflow-style: none /* IE and Edge */;
scrollbar-width: none /* Firefox */;
}
.bookmark-hits-scroll .bookmark-hits-item pre code {
color: $gradedTxtColor
font-size: 0.9em;
}
.bookmark-hits-scroll .bookmark-hits-item pre::-webkit-scrollbar {
display: none;
}
.bookmark-hits-scroll .bookmark-hits-item search-highlight {
color: $gradedTxtColor
background-color: rgba(255,212,0,0.276);
border-radius: 2px;
padding-top: 1px;
padding-bottom: 1px;
padding-left: 3px;
padding-right: 3px;
/* Now remove the padding - but also remove one for the border */
/* This is so that when typing the text around it doesn't move */
margin-left: -4px;
margin-right: -4px;
border: 1px solid rgba(211,176,0,0.402);
}
.bookmark-hits-scroll .bookmark-hits-item-button-contents-top-row
color: $gradedTxtColor
margin-top: 0
margin-bottom: 4px
display:flex
justify-content: space-between
/*
.bookmark-hits-item-contents-crumb-top-row-crumb
*/
.bookmark-hits-item-contents-top-row-tags .bookmark-hits-item-contents-top-row-tags-tag
position:relative
padding-left: $searchPillHorzPadding;
padding-right: $searchPillHorzPadding;
tagColor()
content: 'x'
text-align: center;
/* This is needed because it's not accomplished by the * rule */
box-sizing:border-box
top:0
left: 0
bottom: 0
right: 0
border-radius: 0.5 * $searchPillHeight
tagColor()
content: 'x'
text-align: center;
/* This is needed because it's not accomplished by the * rule */
box-sizing:border-box
top:0
left: 0
bottom: 0
right: 0
border-radius: 0.5 * $searchPillHeight
pill()
content: ' '
text-align: center;
/* This is needed because it's not accomplished by the * rule */
box-sizing:border-box
top:0
left: 0
bottom: 0
right: 0
/* This way it works with any height that occurs */
border-radius: 99px
redPill()
background-color: $redBg
border: 1px solid $redBorder
/**
* By inserting the "pill" background as a :before, we avoid disrupting the perceived size of the tags.
*/
.bookmark-hits-item-contents-top-row-tags .bookmark-hits-item-contents-top-row-tags-tag:before
pill()
.bookmark-hits-scroll .bookmark-hits-item-button-contents-crumb-sep
color: $gradedTxtColorLighter
margin-left: 4px
margin-right: 4px
.bookmark-hits-scroll .bookmark-hits-item-button-contents-top-row .bookmark-hits-item-button-contents-crumb-row-first {
font-weight:bold
}
.bookmark-hits-scroll .bookmark-hits-item-button-contents-top-row .bookmark-hits-item-button-contents-crumb-row-second {
font-weight:bold
}
.bookmark-hits-scroll .bookmark-hits-item-button-contents-top-row .bookmark-hits-item-button-contents-crumb-row-third {
font-weight:bold
}
// ----------------------------------------------------------------------------
// Sidebar
.bookmark-menubar
visibility: hidden
.bookmark-menubar.current
visibility: visible
.bookmark-menubar
antialias()
.section
padding-right: 0
padding-left: $sidepad
padding-bottom: $sidepad
padding-top: 2 * $sidepad
.section + .section
border-top: solid 1px $gradedLine
.section.no-line
border-top: 0
padding-top: 0
code
white-space:pre
font-family:$mono-font
a.big.button
display: block
width: 100%
padding: 10px 20px
text-align: center
font-weight: bold
font-size: 1.1em
background: transparent
border: solid 3px $accent
border-radius: 30px
font-family: $body-font
&, &:visited
color: $accent
text-decoration: none
&:hover, &:focus
text-decoration: none
background: $accent
&, &:visited
color: white
@media (max-width: 480px) /* Mobile */
.bookmark-menubar
padding: $minipad
border-bottom: solid 1px $gradedLine
@media (max-width: 768px) /* Mobile and tablet */
.bookmark-menubar
display: none
@media (min-width: 768px) /* Desktop */
.bookmark-content-root
padding-left: $sidebar-width
.bookmark-menubar
position: absolute
left: 0
top: 0
bottom: 0
width: $sidebar-width
/*border-right: solid 1px $gradedLine */
.bookmark-menubar.fixed
position: fixed
scrollbar()
overflow-y: auto
.bookmark-menubar
font-size: 0.8em
// Sticky left menu:
.bookmark-menu.section
position: -webkit-sticky
position: sticky
/* header height */
top: 35px
.bottom.section
position: -webkit-sticky
position: sticky
/* header height */
top: 35px
// Menu items
.bookmark-menu
ul.level-1 > li + li
margin-top: 20px
a
position: relative
display: block
padding-top: 4px
padding-bottom: 4px
margin-right: ($sidepad * -1)
color: $gradedTxtColorLighter
font-weight: 500!important
&:hover, &:focus
text-decoration: none
color: $accent*0.8
a.level-1
font-family: $body-font
text-transform: uppercase
font-size: 1em
font-weight: bold
&, &:visited
color: $gradedTxtColorLighter
&:hover, &:focus
color: $gradedTxtColorLighter*0.6
a.level-2
font-size: 1em
font-weight: normal
a.level-3
font-weight: normal
font-size: 1em
/* padding-left: 8px */
a.active
&, &:visited, &:hover, &:focus
color: $accent
// Indicator
&:after
visibility: hidden
content: ''
display: block
position: absolute
top: 10px
right: $sidepad
width: 9px
height: 3px
border-radius: 2px
background: $accent
// ----------------------------------------------------------------------------
// Syntax highlighting
code
.string, .number
color: #3ac
.init
color: #383
.keyword
font-weight: bold
.comment
color: $gradedTxtColorLighter * 1.2
// ----------------------------------------------------------------------------
.bookmark-content
.large-brief & > h0:first-child + p,
.large-brief & > h1:first-child + p,
> p.brief
font-size: 1.3em
font-family: $body-font
font-weight: 300
// ----------------------------------------------------------------------------
.title-area
background: linear-gradient(0deg, $gradedHeaderbg 0%, $lowlight-desat-17 100%)
box-sizing: border-box
antialias()
text-align: center
overflow: hidden
img
noselect()
pointer-events: none
> img.bg
z-index: 0
// Start it off screen
position: absolute
left: -9999px
> div
position: relative
z-index: 1
// ----------------- Styles just for "this page" -----------------------------
.title-card
max-height: 70vh;
min-height: 60vh;
text-rendering: optimizeLegibility !important
-webkit-font-smoothing: antialiased !important
-moz-osx-font-smoothing: grayscale
.title-card
/* background: #1d3b47; */
/* background-position: center center; */
/* background-size: cover; */
color: $gradedTxtColorLightest
text-align: center
position: relative
z-index: 1
width: 100%
display: table
.title-card > .in
display: table-cell
vertical-align: middle
.title-card p
font-family: $body-font
color: $gradedTxtColorLightest
letter-spacing: 2px
margin-top: -20px
font-size: 1.3em
@media (max-width: 768px) /* Tablet */
.title-card h5
margin-top: 100px
@media (max-width: 480px) /* Mobile */
.title-card
padding: 50px 0
.title-card p
font-size: 1em
margin-top: -30px
.fixedHeaderContainer {
background: $gradedHeaderbg
border-bottom: solid 1px $gradedLine
border-top: solid 1px $gradedHeaderbg
color: $gradedHeaderLinkColor;
min-height: 50px;
height: 52px
padding: $headerPadding 0;
width: 100%;
z-index: 9999;
-webkit-transform: translateZ(0);
transform: translateZ(0)
display: flex;
position: relative;
right: auto;
top: auto;
width: auto
}
/*
* I have no idea why this makes the search input dock right but that's what we
* want.
* Notes: It's the width 100% on the second child (form) that makes this work.
* Nice!
*/
.fixedHeaderContainer ul.nav,
margin-left: auto
.fixedHeaderContainer .bookmark-search-input
margin-right: auto
@media only screen and (min-width: 1280px) {
.fixedHeaderContainer {
flex-shrink:0
}
}
.fixedHeaderContainer a {
-webkit-box-align: center;
align-items: center;
border: 0;
color: $gradedHeaderLinkColor;
display: -webkit-box;
display: flex;
-webkit-box-orient: horizontal;
-webkit-box-direction: normal;
flex-flow: row nowrap;
height: 34px;
z-index: 10000
text-shadow: $gradedHeaderTextShadow
}
.fixedHeaderContainer h3 {
color: #fff;
font-size: 16px;
margin: 0 0 0 10px;
text-decoration: underline
}
.fixedHeaderContainer a > img {
display: none
}
.fixedHeaderContainer ul {
align-items: center;
box-sizing: border-box;
display: -webkit-box;
display: flex;
flex-wrap: nowrap;
list-style: none;
padding: 0;
width: 100%
}
.fixedHeaderContainer ul li {
-webkit-box-flex: 1;
flex: 1 1 auto;
margin: 0;
text-align: center;
white-space: nowrap
}
.fixedHeaderContainer ul li a {
-webkit-box-align: center;
align-items: center;
box-sizing: border-box;
display: -webkit-box;
display: flex;
font-size: .9em;
height: auto;
-webkit-box-pack: center;
justify-content: center;
margin: 0;
padding: 10px;
-webkit-transition: background-color .3s;
transition: background-color .3s
}
.fixedHeaderContainer ul.nav li.site-nav-group-active > a
color: $headerLinkColorCurrent
font-weight:bold
.fixedHeaderContainer ul.nav li > a:focus,
.fixedHeaderContainer ul.nav li > a:hover
color: $headerLinkColorHover
.dropdown {
border-bottom: 1px solid $gradedLine
pointer-events: none;
position: absolute;
width: 100%
left: 0;
top: $header-height - 2
}
.dropdown.visible {
display: -webkit-box;
display: flex
}
.dropdown.hide {
display: none
}
.dropdown-items a {
background-color: $gradedHeaderbgDarker
border-top: 1px solid $gradedHeaderbgDarker
border-left: 1px solid $gradedHeaderbgDarker
border-right: 1px solid $gradedHeaderbgDarker
}
.dropdown-items a:hover,
.dropdown-items a:focus,
.dropdown-items a:active {
background-color: $gradedHeaderbgDarkest
}
.dropdown-items {
border-bottom: 1px solid $gradedLine
margin-top:$headerPadding + 1px
display: -webkit-box;
display: flex;
-webkit-box-orient: vertical;
-webkit-box-direction: normal;
flex-direction: column;
min-width: 120px;
pointer-events: all
margin-top: 0
border: none
background-color: $gradedHeaderbgDarker
display: -webkit-box;
display: flex;
-webkit-box-orient: horizontal;
-webkit-box-direction: normal;
flex-direction: row
}
@media only screen and (min-width: 1280px) {
.fixedHeaderContainer ul.nav {
display: -webkit-box;
display: flex;
-webkit-box-orient: horizontal;
-webkit-box-direction: normal;
flex-flow: row nowrap;
margin: 0;
padding: 0;
width: auto
}
.fixedHeaderContainer ul.nav li a {
border: 0;
color: $gradedHeaderLinkColor
display: -webkit-box;
display: flex;
margin: 0;
}
}
@media only screen and (max-width: 735px) {
.fixedHeaderContainer ul {
overflow-x:auto
}
.fixedHeaderContainer ul::-webkit-scrollbar {
display: none
}
}
input[type=search] {
-moz-appearance: none;
-webkit-appearance: none
}
.edit-page-link {
float: right;
font-size: 10px;
font-weight: 400;
margin-top: 3px;
text-decoration: none
}
@media only screen and (max-width: 1023px) {
.edit-page-link {
display:none
}
}
.hide {
display: none
}
/**
Text clipping:
background: linear-gradient(to bottom, #fff 0px, #fff 49px, #555 50px, #555 51px);
-webkit-text-fill-color: transparent;
-webkit-background-clip: text;
background-attachment: fixed;
}
*/
================================================
FILE: dune
================================================
(dirs :standard \ node_modules js)
; (install
; (package reason)
; (section bin)
; (files src/refmt/refmt.bc))
================================================
FILE: dune-project
================================================
(lang dune 3.18)
(maintenance_intent "(latest)")
(name reason)
(using menhir 2.0)
(cram enable)
(version 3.17.3)
(generate_opam_files true)
(source
(github reasonml/reason))
(authors "Jordan Walke <jordojw@gmail.com>")
(maintainers
"Jordan Walke <jordojw@gmail.com>"
"Antonio Nuno Monteiro <anmonteiro@gmail.com>")
(homepage "https://reasonml.github.io/")
(bug_reports "https://github.com/reasonml/reason/issues")
(license "MIT")
(package
(name reason)
(synopsis "Reason: Syntax & Toolchain for OCaml")
(description
"Reason gives OCaml a new syntax that is remniscient of languages like\nJavaScript. It's also the umbrella project for a set of tools for the OCaml &\nJavaScript ecosystem.")
(depends
(ocaml
(and
(>= "4.08")
(< "5.6")))
(ocamlfind :build)
(cmdliner
(>= "1.1.0"))
(dune-build-info
(>= 2.9.3))
(menhir
(>= "20180523"))
(merlin-extend
(>= "0.6.2"))
fix
cppo
(ppxlib
(>= 0.36))))
(package
(name rtop)
(synopsis "Reason toplevel")
(description
"rtop is the toplevel (or REPL) for Reason, based on utop (https://github.com/ocaml-community/utop).")
(depends
(ocaml
(and
(>= "4.08")
(< "5.6")))
(reason
(= :version))
(utop
(>= "2.0"))
cppo))
================================================
FILE: esy.json
================================================
{
"name": "reason-cli",
"notes": "This is just the dev package config (also built as globally installable reason-cli). See ./refmt.json ./rtop.json for individual release package configs.",
"license": "MIT",
"version": "3.8.2",
"dependencies": {
"@opam/dune": "> 3.0.0",
"@opam/dune-build-info": "> 3.0.0",
"@opam/fix": "*",
"@opam/menhir": " >= 20180523.0.0",
"@opam/merlin-extend": " >= 0.6.1",
"@opam/ocamlfind": "*",
"@opam/ppxlib": ">= 0.36.0",
"@opam/utop": ">= 2.0",
"ocaml": " >= 4.3.0 < 4.15.0"
},
"devDependencies": {
"@opam/odoc": "*",
"ocaml": "~4.14.0"
},
"notes-ctd": [
"This is how you make an esy monorepo for development, but then release the monorepo as many individual packages:",
"1. Create a packageName-dev esy.json at the root and list the sum of all dependencies",
"2. Set the esy.build command to build a comma delimited list of the package names",
"3. Set the esy.install command to install each of those packages",
"4. Create separate esy.json files for each of those packages (see ./scripts/esy/)",
"5. Copy ./scripts/esy-prepublish.js in to your repo and change packages= to your set of packages."
],
"esy": {
"build": [
[
"dune",
"build",
"-p",
"reason,rtop",
"--disable-promotion"
]
],
"install": [
[
"esy-installer",
"reason.install"
],
[
"esy-installer",
"rtop.install"
]
],
"exportedEnv": {
"INPUT_ARGUMENTS": {
"scope": "global",
"val": "a"
},
"BUILD_REQUESTEDFOREMAIL": {
"scope": "global",
"val": "b"
},
"VSTS_SECRET_VARIABLES": {
"scope": "global",
"val": "c"
},
"SYSTEM_PULLREQUEST_MERGEDAT": {
"scope": "global",
"val": "d"
}
},
"release": {
"bin": [
"rtop",
"refmt"
],
"includePackages": [
"root",
"@opam/base-bytes",
"@opam/base-threads",
"@opam/base-unix",
"@opam/camomile",
"@opam/lambda-term",
"@opam/lwt",
"@opam/lwt_log",
"@opam/lwt_react",
"@opam/menhir",
"@opam/mmap",
"@opam/ocplib-endian",
"@opam/ocamlfind",
"@opam/react",
"@opam/seq",
"@opam/charInfo_width",
"@opam/utop",
"@opam/zed",
"ocaml"
],
"rewritePrefix": true
}
}
}
================================================
FILE: esy.lock.json
================================================
{
"hash": "af23e4b097dab9418dd65b8da739c788",
"root": "root@path:./esy.json",
"node": {
"root@path:./esy.json": {
"record": {
"name": "root",
"version": "path:./esy.json",
"source": "path:./esy.json",
"files": [],
"opam": null
},
"dependencies": [
"@opam/dune@opam:1.4.0", "@opam/menhir@opam:20181006",
"@opam/merlin@opam:3.2.2", "@opam/merlin-extend@opam:0.3",
"@opam/ocaml-migrate-parsetree@opam:1.1.0",
"@opam/ocamlfind@opam:1.8.0", "@opam/result@opam:1.3",
"@opam/utop@opam:2.2.0", "ocaml@4.6.7"
]
},
"ocaml@4.6.7": {
"record": {
"name": "ocaml",
"version": "4.6.7",
"source":
"archive:https://registry.npmjs.org/ocaml/-/ocaml-4.6.7.tgz#sha1:5bfdf7f9b7752646c2a5ad3c9e4021180eeab704",
"files": [],
"opam": null
},
"dependencies": []
},
"@opam/zed@opam:1.6": {
"record": {
"name": "@opam/zed",
"version": "opam:1.6",
"source":
"archive:https://github.com/diml/zed/releases/download/1.6/zed-1.6.tbz#md5:f75c3094af1a22f9801d5ca5eb2d40e0",
"files": [],
"opam": {
"name": "zed",
"version": "1.6",
"opam":
"opam-version: \"2.0\"\nname: \"zed\"\nversion: \"1.6\"\nsynopsis: \"Abstract engine for text edition in OCaml\"\ndescription: \"\"\"\nZed is an abstract engine for text edition. It can be used to write text\neditors, edition widgets, readlines, ... Zed uses Camomile to fully support the\nUnicode specification, and implements an UTF-8 encoded string type with\nvalidation, and a rope datastructure to achieve efficient operations on large\nUnicode buffers. Zed also features a regular expression search on ropes. To\nsupport efficient text edition capabilities, Zed provides macro recording and\ncursor management facilities.\"\"\"\nmaintainer: \"opam-devel@lists.ocaml.org\"\nauthors: \"Jérémie Dimino\"\nlicense: \"BSD3\"\nhomepage: \"https://github.com/diml/zed\"\nbug-reports: \"https://github.com/diml/zed/issues\"\ndepends: [\n \"ocaml\" {>= \"4.02.3\"}\n \"jbuilder\" {build & >= \"1.0+beta9\"}\n \"base-bytes\"\n \"camomile\" {>= \"0.8\"}\n \"react\"\n]\nbuild: [\n [\"jbuilder\" \"subst\" \"-p\" name] {pinned}\n [\"jbuilder\" \"build\" \"-p\" name \"-j\" jobs]\n [\"jbuilder\" \"runtest\" \"-p\" name \"-j\" jobs] {with-test}\n]\ndev-repo: \"git://github.com/diml/zed.git\"\nurl {\n src: \"https://github.com/diml/zed/releases/download/1.6/zed-1.6.tbz\"\n checksum: \"md5=f75c3094af1a22f9801d5ca5eb2d40e0\"\n}",
"override": null
}
},
"dependencies": [
"@esy-ocaml/substs@0.0.1", "@opam/base-bytes@opam:base",
"@opam/camomile@opam:1.0.1", "@opam/jbuilder@opam:transition",
"@opam/react@opam:1.2.1", "ocaml@4.6.7"
]
},
"@opam/yojson@opam:1.4.1": {
"record": {
"name": "@opam/yojson",
"version": "opam:1.4.1",
"source":
"archive:https://github.com/mjambon/yojson/archive/v1.4.1.tar.gz#md5:3ea6e36422dd670e8ab880710d5f7398",
"files": [],
"opam": {
"name": "yojson",
"version": "1.4.1",
"opam":
"opam-version: \"2.0\"\nname: \"yojson\"\nversion: \"1.4.1\"\nsynopsis:\n \"Yojson is an optimized parsing and printing library for the JSON format\"\ndescription: \"\"\"\nIt addresses a few shortcomings of json-wheel including 2x speedup,\npolymorphic variants and optional syntax for tuples and variants.\n\nydump is a pretty-printing command-line program provided with the\nyojson package.\n\nThe program atdgen can be used to derive OCaml-JSON serializers and\ndeserializers from type definitions.\"\"\"\nmaintainer: \"martin@mjambon.com\"\nauthors: \"Martin Jambon\"\nhomepage: \"http://mjambon.com/yojson.html\"\nbug-reports: \"https://github.com/mjambon/yojson/issues\"\ndepends: [\n \"ocaml\" {>= \"4.02.3\"}\n \"jbuilder\" {build}\n \"cppo\" {build}\n \"easy-format\"\n \"biniou\" {>= \"1.2.0\"}\n]\nbuild: [\n [\"jbuilder\" \"build\" \"-p\" name \"-j\" jobs]\n [\"jbuilder\" \"runtest\" \"-p\" name] {with-test}\n]\ndev-repo: \"git+https://github.com/mjambon/yojson.git\"\nurl {\n src: \"https://github.com/mjambon/yojson/archive/v1.4.1.tar.gz\"\n checksum: \"md5=3ea6e36422dd670e8ab880710d5f7398\"\n}",
"override": null
}
},
"dependencies": [
"@esy-ocaml/substs@0.0.1", "@opam/biniou@opam:1.2.0",
"@opam/cppo@opam:1.6.5", "@opam/easy-format@opam:1.3.1",
"@opam/jbuilder@opam:transition", "ocaml@4.6.7"
]
},
"@opam/utop@opam:2.2.0": {
"record": {
"name": "@opam/utop",
"version": "opam:2.2.0",
"source":
"archive:https://github.com/diml/utop/releases/download/2.2.0/utop-2.2.0.tbz#md5:c8e4805883ce27a2ef27b0e4322d6f04",
"files": [
{
"name": "utop-2.2.0.patch",
"content":
"--- ./src/lib/uTop_main.ml\n+++ ./src/lib/uTop_main.ml\n@@ -1308,6 +1308,9 @@\n (* We lost the terminal. *)\n catch Sys.sighup;\n (* Termination request. *)\n+ if Sys.win32 && !emacs_mode then\n+ Sys.set_signal Sys.sigterm Sys.Signal_ignore\n+ else\n catch Sys.sigterm\n \n let load_inputrc () =\n--- ./src/top/expunge/expunge.ml\n+++ ./src/top/expunge/expunge.ml\n@@ -3,7 +3,9 @@\n \n let run_and_read_lines args =\n let cmd = String.concat ~sep:\" \" (List.map args ~f:Filename.quote) in\n+ let cmd = if Sys.win32 then \"\\\"\" ^ cmd ^ \"\\\"\" else cmd in\n let ic = Unix.open_process_in cmd in\n+ set_binary_mode_in ic false;\n let rec loop acc =\n match input_line ic with\n | exception End_of_file -> List.rev acc\n@@ -60,6 +62,7 @@\n (Filename.quote dst)\n (String.concat ~sep:\" \" (S.elements modules_to_keep))\n in\n+ let cmdline = if Sys.win32 then \"\\\"\" ^ cmdline ^ \"\\\"\" else cmdline in\n if verbose then prerr_endline cmdline;\n exit (Sys.command cmdline)\n \n"
}
],
"opam": {
"name": "utop",
"version": "2.2.0",
"opam":
"opam-version: \"2.0\"\nname: \"utop\"\nversion: \"2.2.0\"\nsynopsis: \"Universal toplevel for OCaml\"\ndescription: \"\"\"\nutop is an improved toplevel (i.e., Read-Eval-Print Loop or REPL) for\nOCaml. It can run in a terminal or in Emacs. It supports line\nedition, history, real-time and context sensitive completion, colors,\nand more. It integrates with the Tuareg mode in Emacs.\"\"\"\nmaintainer: \"jeremie@dimino.org\"\nauthors: \"Jérémie Dimino\"\nlicense: \"BSD3\"\nhomepage: \"https://github.com/diml/utop\"\nbug-reports: \"https://github.com/diml/utop/issues\"\ndepends: [\n \"ocaml\" {>= \"4.02.3\"}\n \"base-unix\"\n \"base-threads\"\n \"ocamlfind\" {>= \"1.7.2\"}\n \"lambda-term\" {>= \"1.2\"}\n \"lwt\"\n \"lwt_react\"\n \"camomile\"\n \"react\" {>= \"1.0.0\"}\n \"cppo\" {build & >= \"1.1.2\"}\n \"jbuilder\" {build & >= \"1.0+beta9\"}\n]\nbuild: [\n [\"jbuilder\" \"subst\" \"-p\" name] {pinned}\n [\"jbuilder\" \"build\" \"-p\" name \"-j\" jobs]\n [\"jbuilder\" \"runtest\" \"-p\" name \"-j\" jobs] {with-test}\n]\ndev-repo: \"git+https://github.com/diml/utop.git\"\nurl {\n src: \"https://github.com/diml/utop/releases/download/2.2.0/utop-2.2.0.tbz\"\n checksum: \"md5=c8e4805883ce27a2ef27b0e4322d6f04\"\n}",
"override": {
"build": [
[
"bash", "-c",
"#{os == 'windows' ? 'patch -p1 < utop-2.2.0.patch' : 'true' }"
],
[ "jbuilder", "build", "-p", "utop", "-j", "4" ]
]
}
}
},
"dependencies": [
"@esy-ocaml/substs@0.0.1", "@opam/base-threads@opam:base",
"@opam/base-unix@opam:base", "@opam/camomile@opam:1.0.1",
"@opam/cppo@opam:1.6.5", "@opam/jbuilder@opam:transition",
"@opam/lambda-term@opam:1.13", "@opam/lwt@opam:4.1.0",
"@opam/lwt_react@opam:1.1.1", "@opam/ocamlfind@opam:1.8.0",
"@opam/react@opam:1.2.1", "ocaml@4.6.7"
]
},
"@opam/topkg@opam:1.0.0": {
"record": {
"name": "@opam/topkg",
"version": "opam:1.0.0",
"source":
"archive:http://erratique.ch/software/topkg/releases/topkg-1.0.0.tbz#md5:e3d76bda06bf68cb5853caf6627da603",
"files": [],
"opam": {
"name": "topkg",
"version": "1.0.0",
"opam":
"opam-version: \"2.0\"\nname: \"topkg\"\nversion: \"1.0.0\"\nsynopsis: \"The transitory OCaml software packager\"\ndescription: \"\"\"\nTopkg is a packager for distributing OCaml software. It provides an\nAPI to describe the files a package installs in a given build\nconfiguration and to specify information about the package's\ndistribution, creation and publication procedures.\n\nThe optional topkg-care package provides the `topkg` command line tool\nwhich helps with various aspects of a package's life cycle: creating\nand linting a distribution, releasing it on the WWW, publish its\ndocumentation, add it to the OCaml opam repository, etc.\n\nTopkg is distributed under the ISC license and has **no**\ndependencies. This is what your packages will need as a *build*\ndependency.\n\nTopkg-care is distributed under the ISC license it depends on\n[fmt][fmt], [logs][logs], [bos][bos], [cmdliner][cmdliner],\n[webbrowser][webbrowser] and `opam-format`.\n\n[fmt]: http://erratique.ch/software/fmt\n[logs]: http://erratique.ch/software/logs\n[bos]: http://erratique.ch/software/bos\n[cmdliner]: http://erratique.ch/software/cmdliner\n[webbrowser]: http://erratique.ch/software/webbrowser\"\"\"\nmaintainer: \"Daniel Bünzli <daniel.buenzl i@erratique.ch>\"\nauthors: \"Daniel Bünzli <daniel.buenzl i@erratique.ch>\"\nlicense: \"ISC\"\ntags: [\"packaging\" \"ocamlbuild\" \"org:erratique\"]\nhomepage: \"http://erratique.ch/software/topkg\"\ndoc: \"http://erratique.ch/software/topkg/doc\"\nbug-reports: \"https://github.com/dbuenzli/topkg/issues\"\ndepends: [\n \"ocaml\" {>= \"4.01.0\"}\n \"ocamlfind\" {build & >= \"1.6.1\"}\n \"ocamlbuild\"\n \"result\"\n]\nbuild: [\n \"ocaml\" \"pkg/pkg.ml\" \"build\" \"--pkg-name\" name \"--dev-pkg\" \"%{pinned}%\"\n]\ndev-repo: \"git+http://erratique.ch/repos/topkg.git\"\nurl {\n src: \"http://erratique.ch/software/topkg/releases/topkg-1.0.0.tbz\"\n checksum: \"md5=e3d76bda06bf68cb5853caf6627da603\"\n}",
"override": null
}
},
"dependencies": [
"@esy-ocaml/substs@0.0.1", "@opam/ocamlbuild@opam:0.12.0",
"@opam/ocamlfind@opam:1.8.0", "@opam/result@opam:1.3", "ocaml@4.6.7"
]
},
"@opam/result@opam:1.3": {
"record": {
"name": "@opam/result",
"version": "opam:1.3",
"source":
"archive:https://github.com/janestreet/result/releases/download/1.3/result-1.3.tbz#md5:4beebefd41f7f899b6eeba7414e7ae01",
"files": [],
"opam": {
"name": "result",
"version": "1.3",
"opam":
"opam-version: \"2.0\"\nname: \"result\"\nversion: \"1.3\"\nsynopsis: \"Compatibility Result module\"\ndescription: \"\"\"\nProjects that want to use the new result type defined in OCaml >= 4.03\nwhile staying compatible with older version of OCaml should use the\nResult module defined in this library.\"\"\"\nmaintainer: \"opensource@janestreet.com\"\nauthors: \"Jane Street Group, LLC <opensource@janestreet.com>\"\nlicense: \"BSD3\"\nhomepage: \"https://github.com/janestreet/result\"\nbug-reports: \"https://github.com/janestreet/result/issues\"\ndepends: [\n \"ocaml\"\n \"jbuilder\" {build & >= \"1.0+beta11\"}\n]\nbuild: [\"jbuilder\" \"build\" \"-p\" name \"-j\" jobs]\ndev-repo: \"git+https://github.com/janestreet/result.git\"\nurl {\n src:\n \"https://github.com/janestreet/result/releases/download/1.3/result-1.3.tbz\"\n checksum: \"md5=4beebefd41f7f899b6eeba7414e7ae01\"\n}",
"override": null
}
},
"dependencies": [
"@esy-ocaml/substs@0.0.1", "@opam/jbuilder@opam:transition",
"ocaml@4.6.7"
]
},
"@opam/react@opam:1.2.1": {
"record": {
"name": "@opam/react",
"version": "opam:1.2.1",
"source":
"archive:http://erratique.ch/software/react/releases/react-1.2.1.tbz#md5:ce1454438ce4e9d2931248d3abba1fcc",
"files": [],
"opam": {
"name": "react",
"version": "1.2.1",
"opam":
"opam-version: \"2.0\"\nname: \"react\"\nversion: \"1.2.1\"\nsynopsis: \"Declarative events and signals for OCaml\"\ndescription: \"\"\"\nRelease %%VERSION%%\n\nReact is an OCaml module for functional reactive programming (FRP). It\nprovides support to program with time varying values : declarative\nevents and signals. React doesn't define any primitive event or\nsignal, it lets the client chooses the concrete timeline.\n\nReact is made of a single, independent, module and distributed under\nthe ISC license.\"\"\"\nmaintainer: \"Daniel Bünzli <daniel.buenzl i@erratique.ch>\"\nauthors: \"Daniel Bünzli <daniel.buenzl i@erratique.ch>\"\nlicense: \"ISC\"\ntags: [\"reactive\" \"declarative\" \"signal\" \"event\" \"frp\" \"org:erratique\"]\nhomepage: \"http://erratique.ch/software/react\"\ndoc: \"http://erratique.ch/software/react/doc/React\"\nbug-reports: \"https://github.com/dbuenzli/react/issues\"\ndepends: [\n \"ocaml\" {>= \"4.01.0\"}\n \"ocamlfind\" {build}\n \"ocamlbuild\" {build}\n \"topkg\" {build & >= \"0.9.0\"}\n]\nbuild: [\"ocaml\" \"pkg/pkg.ml\" \"build\" \"--dev-pkg\" \"%{pinned}%\"]\ndev-repo: \"git+http://erratique.ch/repos/react.git\"\nurl {\n src: \"http://erratique.ch/software/react/releases/react-1.2.1.tbz\"\n checksum: \"md5=ce1454438ce4e9d2931248d3abba1fcc\"\n}",
"override": null
}
},
"dependencies": [
"@esy-ocaml/substs@0.0.1", "@opam/ocamlbuild@opam:0.12.0",
"@opam/ocamlfind@opam:1.8.0", "@opam/topkg@opam:1.0.0", "ocaml@4.6.7"
]
},
"@opam/ocamlfind@opam:1.8.0": {
"record": {
"name": "@opam/ocamlfind",
"version": "opam:1.8.0",
"source": [
"archive:http://download.camlcity.org/download/findlib-1.8.0.tar.gz#md5:a710c559667672077a93d34eb6a42e5b",
"archive:http://download2.camlcity.org/download/findlib-1.8.0.tar.gz#md5:a710c559667672077a93d34eb6a42e5b"
],
"files": [
{
"name": "ocaml-stub",
"content":
"#!/bin/sh\n\nBINDIR=$(dirname \"$(command -v ocamlc)\")\n\"$BINDIR/ocaml\" -I \"$OCAML_TOPLEVEL_PATH\" \"$@\"\n"
},
{
"name": "ocamlfind.install",
"content":
"bin: [\n \"src/findlib/ocamlfind\" {\"ocamlfind\"}\n \"?src/findlib/ocamlfind_opt\" {\"ocamlfind\"}\n \"?tools/safe_camlp4\"\n]\ntoplevel: [\"src/findlib/topfind\"]\n"
},
{
"name": "findlib-1.8.0.patch",
"content":
"--- ./Makefile\n+++ ./Makefile\n@@ -57,16 +57,16 @@\n \tcat findlib.conf.in | \\\n \t $(SH) tools/patch '@SITELIB@' '$(OCAML_SITELIB)' >findlib.conf\n \tif ./tools/cmd_from_same_dir ocamlc; then \\\n-\t\techo 'ocamlc=\"ocamlc.opt\"' >>findlib.conf; \\\n+\t\techo 'ocamlc=\"ocamlc.opt$(EXEC_SUFFIX)\"' >>findlib.conf; \\\n \tfi\n \tif ./tools/cmd_from_same_dir ocamlopt; then \\\n-\t\techo 'ocamlopt=\"ocamlopt.opt\"' >>findlib.conf; \\\n+\t\techo 'ocamlopt=\"ocamlopt.opt$(EXEC_SUFFIX)\"' >>findlib.conf; \\\n \tfi\n \tif ./tools/cmd_from_same_dir ocamldep; then \\\n-\t\techo 'ocamldep=\"ocamldep.opt\"' >>findlib.conf; \\\n+\t\techo 'ocamldep=\"ocamldep.opt$(EXEC_SUFFIX)\"' >>findlib.conf; \\\n \tfi\n \tif ./tools/cmd_from_same_dir ocamldoc; then \\\n-\t\techo 'ocamldoc=\"ocamldoc.opt\"' >>findlib.conf; \\\n+\t\techo 'ocamldoc=\"ocamldoc.opt$(EXEC_SUFFIX)\"' >>findlib.conf; \\\n \tfi\n \n .PHONY: install-doc\n--- ./src/findlib/findlib_config.mlp\n+++ ./src/findlib/findlib_config.mlp\n@@ -24,3 +24,5 @@\n | \"MacOS\" -> \"\" (* don't know *)\n | _ -> failwith \"Unknown Sys.os_type\"\n ;;\n+\n+let exec_suffix = \"@EXEC_SUFFIX@\";;\n--- ./src/findlib/findlib.ml\n+++ ./src/findlib/findlib.ml\n@@ -28,15 +28,20 @@\n let conf_ldconf = ref \"\";;\n let conf_ignore_dups_in = ref ([] : string list);;\n \n-let ocamlc_default = \"ocamlc\";;\n-let ocamlopt_default = \"ocamlopt\";;\n-let ocamlcp_default = \"ocamlcp\";;\n-let ocamloptp_default = \"ocamloptp\";;\n-let ocamlmklib_default = \"ocamlmklib\";;\n-let ocamlmktop_default = \"ocamlmktop\";;\n-let ocamldep_default = \"ocamldep\";;\n-let ocamlbrowser_default = \"ocamlbrowser\";;\n-let ocamldoc_default = \"ocamldoc\";;\n+let add_exec str =\n+ match Findlib_config.exec_suffix with\n+ | \"\" -> str\n+ | a -> str ^ a ;;\n+let ocamlc_default = add_exec \"ocamlc\";;\n+let ocamlopt_default = add_exec \"ocamlopt\";;\n+let ocamlcp_default = add_exec \"ocamlcp\";;\n+let ocamloptp_default = add_exec \"ocamloptp\";;\n+let ocamlmklib_default = add_exec \"ocamlmklib\";;\n+let ocamlmktop_default = add_exec \"ocamlmktop\";;\n+let ocamldep_default = add_exec \"ocamldep\";;\n+let ocamlbrowser_default = add_exec \"ocamlbrowser\";;\n+let ocamldoc_default = add_exec \"ocamldoc\";;\n+\n \n \n let init_manually \n--- ./src/findlib/fl_package_base.ml\n+++ ./src/findlib/fl_package_base.ml\n@@ -133,7 +133,15 @@\n \t List.find (fun def -> def.def_var = \"exists_if\") p.package_defs in\n \tlet files = Fl_split.in_words def.def_value in\n \tList.exists \n-\t (fun file -> Sys.file_exists (Filename.concat d' file))\n+\t (fun file ->\n+ let fln = Filename.concat d' file in\n+ let e = Sys.file_exists fln in\n+ (* necessary for ppx executables *)\n+ if e || Sys.os_type <> \"Win32\" || Filename.check_suffix fln \".exe\" then\n+ e\n+ else\n+ Sys.file_exists (fln ^ \".exe\")\n+ )\n \t files\n with Not_found -> true in\n \n--- ./src/findlib/fl_split.ml\n+++ ./src/findlib/fl_split.ml\n@@ -126,10 +126,17 @@\n | '/' | '\\\\' -> true\n | _ -> false in\n let norm_dir_win() =\n- if l >= 1 && s.[0] = '/' then\n- Buffer.add_char b '\\\\' else Buffer.add_char b s.[0];\n- if l >= 2 && s.[1] = '/' then\n- Buffer.add_char b '\\\\' else Buffer.add_char b s.[1];\n+ if l >= 1 then (\n+ if s.[0] = '/' then\n+ Buffer.add_char b '\\\\'\n+ else\n+ Buffer.add_char b s.[0] ;\n+ if l >= 2 then\n+ if s.[1] = '/' then\n+ Buffer.add_char b '\\\\'\n+ else\n+ Buffer.add_char b s.[1];\n+ );\n for k = 2 to l - 1 do\n let c = s.[k] in\n if is_slash c then (\n--- ./src/findlib/frontend.ml\n+++ ./src/findlib/frontend.ml\n@@ -31,10 +31,18 @@\n else\n Sys_error (arg ^ \": \" ^ Unix.error_message code)\n \n+let is_win = Sys.os_type = \"Win32\"\n+\n+let () =\n+ match Findlib_config.system with\n+ | \"win32\" | \"win64\" | \"mingw\" | \"cygwin\" | \"mingw64\" | \"cygwin64\" ->\n+ (try set_binary_mode_out stdout true with _ -> ());\n+ (try set_binary_mode_out stderr true with _ -> ());\n+ | _ -> ()\n \n let slashify s =\n match Findlib_config.system with\n- | \"mingw\" | \"mingw64\" | \"cygwin\" ->\n+ | \"win32\" | \"win64\" | \"mingw\" | \"cygwin\" | \"mingw64\" | \"cygwin64\" ->\n let b = Buffer.create 80 in\n String.iter\n (function\n@@ -49,7 +57,7 @@\n \n let out_path ?(prefix=\"\") s =\n match Findlib_config.system with\n- | \"mingw\" | \"mingw64\" | \"cygwin\" ->\n+ | \"win32\" | \"win64\" | \"mingw\" | \"mingw64\" | \"cygwin\" ->\n \tlet u = slashify s in\n \tprefix ^ \n \t (if String.contains u ' ' then\n@@ -273,11 +281,9 @@\n \n \n let identify_dir d =\n- match Sys.os_type with\n- | \"Win32\" ->\n-\tfailwith \"identify_dir\" (* not available *)\n- | _ ->\n-\tlet s = Unix.stat d in\n+ if is_win then\n+ failwith \"identify_dir\"; (* not available *)\n+ let s = Unix.stat d in\n \t(s.Unix.st_dev, s.Unix.st_ino)\n ;;\n \n@@ -459,6 +465,96 @@\n )\n packages\n \n+let rewrite_cmd s =\n+ if s = \"\" || not is_win then\n+ s\n+ else\n+ let s =\n+ let l = String.length s in\n+ let b = Buffer.create l in\n+ for i = 0 to pred l do\n+ match s.[i] with\n+ | '/' -> Buffer.add_char b '\\\\'\n+ | x -> Buffer.add_char b x\n+ done;\n+ Buffer.contents b\n+ in\n+ if (Filename.is_implicit s && String.contains s '\\\\' = false) ||\n+ Filename.check_suffix (String.lowercase s) \".exe\" then\n+ s\n+ else\n+ let s' = s ^ \".exe\" in\n+ if Sys.file_exists s' then\n+ s'\n+ else\n+ s\n+\n+let rewrite_cmd s =\n+ if s = \"\" || not is_win then s else\n+ let s =\n+ let l = String.length s in\n+ let b = Buffer.create l in\n+ for i = 0 to pred l do\n+ match s.[i] with\n+ | '/' -> Buffer.add_char b '\\\\'\n+ | x -> Buffer.add_char b x\n+ done;\n+ Buffer.contents b\n+ in\n+ if (Filename.is_implicit s && String.contains s '\\\\' = false) ||\n+ Filename.check_suffix (String.lowercase s) \".exe\" then\n+ s\n+ else\n+ let s' = s ^ \".exe\" in\n+ if Sys.file_exists s' then\n+ s'\n+ else\n+ s\n+\n+let rewrite_pp cmd =\n+ if not is_win then cmd else\n+ let module T = struct exception Keep end in\n+ let is_whitespace = function\n+ | ' ' | '\\011' | '\\012' | '\\n' | '\\r' | '\\t' -> true\n+ | _ -> false in\n+ (* characters that triggers special behaviour (cmd.exe, not unix shell) *)\n+ let is_unsafe_char = function\n+ | '(' | ')' | '%' | '!' | '^' | '<' | '>' | '&' -> true\n+ | _ -> false in\n+ let len = String.length cmd in\n+ let buf = Buffer.create (len + 4) in\n+ let buf_cmd = Buffer.create len in\n+ let rec iter_ws i =\n+ if i >= len then () else\n+ let cur = cmd.[i] in\n+ if is_whitespace cur then (\n+ Buffer.add_char buf cur;\n+ iter_ws (succ i)\n+ )\n+ else\n+ iter_cmd i\n+ and iter_cmd i =\n+ if i >= len then add_buf_cmd () else\n+ let cur = cmd.[i] in\n+ if is_unsafe_char cur || cur = '\"' || cur = '\\'' then\n+ raise T.Keep;\n+ if is_whitespace cur then (\n+ add_buf_cmd ();\n+ Buffer.add_substring buf cmd i (len - i)\n+ )\n+ else (\n+ Buffer.add_char buf_cmd cur;\n+ iter_cmd (succ i)\n+ )\n+ and add_buf_cmd () =\n+ if Buffer.length buf_cmd > 0 then\n+ Buffer.add_string buf (rewrite_cmd (Buffer.contents buf_cmd))\n+ in\n+ try\n+ iter_ws 0;\n+ Buffer.contents buf\n+ with\n+ | T.Keep -> cmd\n \n let process_pp_spec syntax_preds packages pp_opts =\n (* Returns: pp_command *)\n@@ -549,7 +645,7 @@\n None -> []\n | Some cmd ->\n \t[\"-pp\";\n-\t cmd ^ \" \" ^\n+\t (rewrite_cmd cmd) ^ \" \" ^\n \t String.concat \" \" (List.map Filename.quote pp_i_options) ^ \" \" ^\n \t String.concat \" \" (List.map Filename.quote pp_archives) ^ \" \" ^\n \t String.concat \" \" (List.map Filename.quote pp_opts)]\n@@ -625,9 +721,11 @@\n in\n try\n let preprocessor =\n+ rewrite_cmd (\n resolve_path\n ~base ~explicit:true\n- (package_property predicates pname \"ppx\") in\n+ (package_property predicates pname \"ppx\") )\n+ in\n [\"-ppx\"; String.concat \" \" (preprocessor :: options)]\n with Not_found -> []\n )\n@@ -895,6 +993,14 @@\n switch (e.g. -L<path> instead of -L <path>)\n *)\n \n+(* We may need to remove files on which we do not have complete control.\n+ On Windows, removing a read-only file fails so try to change the\n+ mode of the file first. *)\n+let remove_file fname =\n+ try Sys.remove fname\n+ with Sys_error _ when is_win ->\n+ (try Unix.chmod fname 0o666 with Unix.Unix_error _ -> ());\n+ Sys.remove fname\n \n let ocamlc which () =\n \n@@ -1022,9 +1128,12 @@\n \n \t \"-intf\", \n \t Arg.String (fun s -> pass_files := !pass_files @ [ Intf(slashify s) ]);\n- \n+\n \t \"-pp\", \n-\t Arg.String (fun s -> pp_specified := true; add_spec_fn \"-pp\" s);\n+\t Arg.String (fun s -> pp_specified := true; add_spec_fn \"-pp\" (rewrite_pp s));\n+\n+ \"-ppx\",\n+ Arg.String (fun s -> add_spec_fn \"-ppx\" (rewrite_pp s));\n \t \n \t \"-thread\", \n \t Arg.Unit (fun _ -> threads := threads_default);\n@@ -1237,7 +1346,7 @@\n with\n any ->\n \tclose_out initl;\n-\tSys.remove initl_file_name;\n+\tremove_file initl_file_name;\n \traise any\n end;\n \n@@ -1245,9 +1354,9 @@\n at_exit\n (fun () ->\n \tlet tr f x = try f x with _ -> () in\n-\ttr Sys.remove initl_file_name;\n-\ttr Sys.remove (Filename.chop_extension initl_file_name ^ \".cmi\");\n-\ttr Sys.remove (Filename.chop_extension initl_file_name ^ \".cmo\");\n+\ttr remove_file initl_file_name;\n+\ttr remove_file (Filename.chop_extension initl_file_name ^ \".cmi\");\n+\ttr remove_file (Filename.chop_extension initl_file_name ^ \".cmo\");\n );\n \n let exclude_list = [ stdlibdir; threads_dir; vmthreads_dir ] in\n@@ -1493,7 +1602,9 @@\n \t [ \"-v\", Arg.Unit (fun () -> verbose := Verbose);\n \t \"-pp\", Arg.String (fun s ->\n \t\t\t\t pp_specified := true;\n-\t\t\t\t options := !options @ [\"-pp\"; s]);\n+\t\t\t\t options := !options @ [\"-pp\"; rewrite_pp s]);\n+ \"-ppx\", Arg.String (fun s ->\n+\t\t\t\t options := !options @ [\"-ppx\"; rewrite_pp s]);\n \t ]\n )\n )\n@@ -1672,7 +1783,9 @@\n \t Arg.String (fun s -> add_spec_fn \"-I\" (slashify (resolve_path s)));\n \n \t \"-pp\", Arg.String (fun s -> pp_specified := true;\n-\t\t \t add_spec_fn \"-pp\" s);\n+ add_spec_fn \"-pp\" (rewrite_pp s));\n+ \"-ppx\", Arg.String (fun s -> add_spec_fn \"-ppx\" (rewrite_pp s));\n+\n \t ]\n \t)\n )\n@@ -1830,7 +1943,10 @@\n output_string ch_out append;\n close_out ch_out;\n close_in ch_in;\n- Unix.utimes outpath s.Unix.st_mtime s.Unix.st_mtime;\n+ (try Unix.utimes outpath s.Unix.st_mtime s.Unix.st_mtime\n+ with Unix.Unix_error(e,_,_) ->\n+ prerr_endline(\"Warning: setting utimes for \" ^ outpath\n+ ^ \": \" ^ Unix.error_message e));\n \n prerr_endline(\"Installed \" ^ outpath);\n with\n@@ -1882,6 +1998,8 @@\n Unix.openfile (Filename.concat dir owner_file) [Unix.O_RDONLY] 0 in\n let f =\n Unix.in_channel_of_descr fd in\n+ if is_win then\n+ set_binary_mode_in f false;\n try\n let line = input_line f in\n let is_my_file = (line = pkg) in\n@@ -2208,7 +2326,7 @@\n let lines = read_ldconf !ldconf in\n let dlldir_norm = Fl_split.norm_dir dlldir in\n let dlldir_norm_lc = string_lowercase_ascii dlldir_norm in\n- let ci_filesys = (Sys.os_type = \"Win32\") in\n+ let ci_filesys = is_win in\n let check_dir d =\n let d' = Fl_split.norm_dir d in\n (d' = dlldir_norm) || \n@@ -2356,7 +2474,7 @@\n List.iter\n (fun file ->\n let absfile = Filename.concat dlldir file in\n- Sys.remove absfile;\n+ remove_file absfile;\n prerr_endline (\"Removed \" ^ absfile)\n )\n dll_files\n@@ -2365,7 +2483,7 @@\n (* Remove the files from the package directory: *)\n if Sys.file_exists pkgdir then begin\n let files = Sys.readdir pkgdir in\n- Array.iter (fun f -> Sys.remove (Filename.concat pkgdir f)) files;\n+ Array.iter (fun f -> remove_file (Filename.concat pkgdir f)) files;\n Unix.rmdir pkgdir;\n prerr_endline (\"Removed \" ^ pkgdir)\n end\n@@ -2415,7 +2533,9 @@\n \n \n let print_configuration() =\n+ let sl = slashify in\n let dir s =\n+ let s = sl s in\n if Sys.file_exists s then\n s\n else\n@@ -2453,27 +2573,27 @@\n \t if md = \"\" then \"the corresponding package directories\" else dir md\n \t );\n \tPrintf.printf \"The standard library is assumed to reside in:\\n %s\\n\"\n-\t (Findlib.ocaml_stdlib());\n+ (sl (Findlib.ocaml_stdlib()));\n \tPrintf.printf \"The ld.conf file can be found here:\\n %s\\n\"\n-\t (Findlib.ocaml_ldconf());\n+ (sl (Findlib.ocaml_ldconf()));\n \tflush stdout\n | Some \"conf\" ->\n-\tprint_endline Findlib_config.config_file\n+ print_endline (sl Findlib_config.config_file)\n | Some \"path\" ->\n-\tList.iter print_endline (Findlib.search_path())\n+ List.iter ( fun x -> print_endline (sl x)) (Findlib.search_path())\n | Some \"destdir\" ->\n-\tprint_endline (Findlib.default_location())\n+ print_endline ( sl (Findlib.default_location()))\n | Some \"metadir\" ->\n-\tprint_endline (Findlib.meta_directory())\n+ print_endline ( sl (Findlib.meta_directory()))\n | Some \"metapath\" ->\n let mdir = Findlib.meta_directory() in\n let ddir = Findlib.default_location() in\n-\tprint_endline \n- (if mdir <> \"\" then mdir ^ \"/META.%s\" else ddir ^ \"/%s/META\")\n+ print_endline ( sl\n+ (if mdir <> \"\" then mdir ^ \"/META.%s\" else ddir ^ \"/%s/META\"))\n | Some \"stdlib\" ->\n-\tprint_endline (Findlib.ocaml_stdlib())\n+ print_endline ( sl (Findlib.ocaml_stdlib()))\n | Some \"ldconf\" ->\n-\tprint_endline (Findlib.ocaml_ldconf())\n+ print_endline ( sl (Findlib.ocaml_ldconf()))\n | _ ->\n \tassert false\n ;;\n@@ -2481,7 +2601,7 @@\n \n let ocamlcall pkg cmd =\n let dir = package_directory pkg in\n- let path = Filename.concat dir cmd in\n+ let path = rewrite_cmd (Filename.concat dir cmd) in\n begin\n try Unix.access path [ Unix.X_OK ]\n with\n@@ -2647,6 +2767,10 @@\n | Sys_error f ->\n prerr_endline (\"ocamlfind: \" ^ f);\n exit 2\n+ | Unix.Unix_error (e, fn, f) ->\n+ prerr_endline (\"ocamlfind: \" ^ fn ^ \" \" ^ f\n+ ^ \": \" ^ Unix.error_message e);\n+ exit 2\n | Findlib.No_such_package(pkg,info) ->\n prerr_endline (\"ocamlfind: Package `\" ^ pkg ^ \"' not found\" ^\n \t\t (if info <> \"\" then \" - \" ^ info else \"\"));\n--- ./src/findlib/Makefile\n+++ ./src/findlib/Makefile\n@@ -90,6 +90,7 @@\n \tcat findlib_config.mlp | \\\n \t $(SH) $(TOP)/tools/patch '@CONFIGFILE@' '$(OCAMLFIND_CONF)' | \\\n \t $(SH) $(TOP)/tools/patch '@STDLIB@' '$(OCAML_CORE_STDLIB)' | \\\n+\t\t\t$(SH) $(TOP)/tools/patch '@EXEC_SUFFIX@' '$(EXEC_SUFFIX)' | \\\n \t\tsed -e 's;@AUTOLINK@;$(OCAML_AUTOLINK);g' \\\n \t\t -e 's;@SYSTEM@;$(SYSTEM);g' \\\n \t\t >findlib_config.ml\n@@ -113,7 +114,7 @@\n \t$(OCAMLC) -a -o num_top.cma $(NUMTOP_OBJECTS)\n \n clean:\n-\trm -f *.cmi *.cmo *.cma *.cmx *.a *.o *.cmxa \\\n+\trm -f *.cmi *.cmo *.cma *.cmx *.lib *.a *.o *.cmxa \\\n \t fl_meta.ml findlib_config.ml findlib.mml topfind.ml topfind \\\n \t ocamlfind$(EXEC_SUFFIX) ocamlfind_opt$(EXEC_SUFFIX)\n \n@@ -121,7 +122,7 @@\n \tmkdir -p \"$(prefix)$(OCAML_SITELIB)/$(NAME)\"\n \tmkdir -p \"$(prefix)$(OCAMLFIND_BIN)\"\n \ttest $(INSTALL_TOPFIND) -eq 0 || cp topfind \"$(prefix)$(OCAML_CORE_STDLIB)\"\n-\tfiles=`$(SH) $(TOP)/tools/collect_files $(TOP)/Makefile.config findlib.cmi findlib.mli findlib.cma findlib.cmxa findlib.a findlib.cmxs topfind.cmi topfind.mli fl_package_base.mli fl_package_base.cmi fl_metascanner.mli fl_metascanner.cmi fl_metatoken.cmi findlib_top.cma findlib_top.cmxa findlib_top.a findlib_top.cmxs findlib_dynload.cma findlib_dynload.cmxa findlib_dynload.a findlib_dynload.cmxs fl_dynload.mli fl_dynload.cmi META` && \\\n+\tfiles=`$(SH) $(TOP)/tools/collect_files $(TOP)/Makefile.config findlib.cmi findlib.mli findlib.cma findlib.cmxa findlib$(LIB_SUFFIX) findlib.cmxs topfind.cmi topfind.mli fl_package_base.mli fl_package_base.cmi fl_metascanner.mli fl_metascanner.cmi fl_metatoken.cmi findlib_top.cma findlib_top.cmxa findlib_top$(LIB_SUFFIX) findlib_top.cmxs findlib_dynload.cma findlib_dynload.cmxa findlib_dynload$(LIB_SUFFIX) findlib_dynload.cmxs fl_dynload.mli fl_dynload.cmi META` && \\\n \tcp $$files \"$(prefix)$(OCAML_SITELIB)/$(NAME)\"\n \tf=\"ocamlfind$(EXEC_SUFFIX)\"; { test -f ocamlfind_opt$(EXEC_SUFFIX) && f=\"ocamlfind_opt$(EXEC_SUFFIX)\"; }; \\\n \tcp $$f \"$(prefix)$(OCAMLFIND_BIN)/ocamlfind$(EXEC_SUFFIX)\"\n"
}
],
"opam": {
"name": "ocamlfind",
"version": "1.8.0",
"opam":
"opam-version: \"2.0\"\nname: \"ocamlfind\"\nversion: \"1.8.0\"\nsynopsis: \"A library manager for OCaml\"\ndescription: \"\"\"\nFindlib is a library manager for OCaml. It provides a convention how\nto store libraries, and a file format (\"META\") to describe the\nproperties of libraries. There is also a tool (ocamlfind) for\ninterpreting the META files, so that it is very easy to use libraries\nin programs and scripts.\"\"\"\nmaintainer: \"Thomas Gazagnaire <thomas@gazagnaire.org>\"\nauthors: \"Gerd Stolpmann <gerd@gerd-stolpmann.de>\"\nhomepage: \"http://projects.camlcity.org/projects/findlib.html\"\nbug-reports: \"https://gitlab.camlcity.org/gerd/lib-findlib/issues\"\ndepends: [\n \"ocaml\" {>= \"4.00.0\"}\n \"conf-m4\" {build}\n]\nbuild: [\n [\n \"./configure\"\n \"-bindir\"\n bin\n \"-sitelib\"\n lib\n \"-mandir\"\n man\n \"-config\"\n \"%{lib}%/findlib.conf\"\n \"-no-custom\"\n \"-no-topfind\" {ocaml:preinstalled}\n ]\n [make \"all\"]\n [make \"opt\"] {ocaml:native}\n]\ninstall: [\n [make \"install\"]\n [\"install\" \"-m\" \"0755\" \"ocaml-stub\" \"%{bin}%/ocaml\"] {ocaml:preinstalled}\n]\nremove: [\n [\"ocamlfind\" \"remove\" \"bytes\"]\n [\n \"./configure\"\n \"-bindir\"\n bin\n \"-sitelib\"\n lib\n \"-mandir\"\n man\n \"-config\"\n \"%{lib}%/findlib.conf\"\n \"-no-topfind\" {ocaml:preinstalled}\n ]\n [make \"uninstall\"]\n [\"rm\" \"-f\" \"%{bin}%/ocaml\"] {ocaml:preinstalled}\n]\ndev-repo: \"git+https://gitlab.camlcity.org/gerd/lib-findlib.git\"\nextra-files: [\n [\"ocamlfind.install\" \"md5=06f2c282ab52d93aa6adeeadd82a2543\"]\n [\"ocaml-stub\" \"md5=181f259c9e0bad9ef523e7d4abfdf87a\"]\n]\nurl {\n src: \"http://download.camlcity.org/download/findlib-1.8.0.tar.gz\"\n checksum: \"md5=a710c559667672077a93d34eb6a42e5b\"\n mirrors: \"http://download2.camlcity.org/download/findlib-1.8.0.tar.gz\"\n}",
"override": {
"build": [
[
"bash", "-c",
"#{os == 'windows' ? 'patch -p1 < findlib-1.8.0.patch' : 'true'}"
],
[
"./configure", "-bindir", "#{self.bin}", "-sitelib",
"#{self.lib}", "-mandir", "#{self.man}", "-config",
"#{self.lib}/findlib.conf", "-no-custom", "-no-topfind"
],
[ "make", "all" ],
[ "make", "opt" ]
],
"install": [
[ "make", "install" ],
[ "install", "-m", "0755", "ocaml-stub", "#{self.bin}/ocaml" ],
[ "mkdir", "-p", "#{self.toplevel}" ],
[
"install", "-m", "0644", "src/findlib/topfind",
"#{self.toplevel}/topfind"
]
],
"exportedEnv": {
"OCAML_TOPLEVEL_PATH": {
"val": "#{self.toplevel}",
"scope": "global",
"exclusive": false
}
}
}
}
},
"dependencies": [
"@esy-ocaml/substs@0.0.1", "@opam/conf-m4@opam:1", "ocaml@4.6.7"
]
},
"@opam/ocamlbuild@opam:0.12.0": {
"record": {
"name": "@opam/ocamlbuild",
"version": "opam:0.12.0",
"source":
"archive:https://github.com/ocaml/ocamlbuild/archive/0.12.0.tar.gz#md5:442baa19470bd49150f153122e22907b",
"files": [
{
"name": "ocamlbuild-0.12.0.patch",
"content":
"--- ./Makefile\n+++ ./Makefile\n@@ -213,7 +213,7 @@\n \trm -f man/ocamlbuild.1\n \n man/options_man.byte: src/ocamlbuild_pack.cmo\n-\t$(OCAMLC) $^ -I src man/options_man.ml -o man/options_man.byte\n+\t$(OCAMLC) -I +unix unix.cma $^ -I src man/options_man.ml -o man/options_man.byte\n \n clean::\n \trm -f man/options_man.cm*\n--- ./src/command.ml\n+++ ./src/command.ml\n@@ -148,9 +148,10 @@\n let self = string_of_command_spec_with_calls call_with_tags call_with_target resolve_virtuals in\n let b = Buffer.create 256 in\n (* The best way to prevent bash from switching to its windows-style\n- * quote-handling is to prepend an empty string before the command name. *)\n+ * quote-handling is to prepend an empty string before the command name.\n+ * space seems to work, too - and the ouput is nicer *)\n if Sys.os_type = \"Win32\" then\n- Buffer.add_string b \"''\";\n+ Buffer.add_char b ' ';\n let first = ref true in\n let put_space () =\n if !first then\n@@ -260,7 +261,7 @@\n \n let execute_many ?(quiet=false) ?(pretend=false) cmds =\n add_parallel_stat (List.length cmds);\n- let degraded = !*My_unix.is_degraded || Sys.os_type = \"Win32\" in\n+ let degraded = !*My_unix.is_degraded in\n let jobs = !jobs in\n if jobs < 0 then invalid_arg \"jobs < 0\";\n let max_jobs = if jobs = 0 then None else Some jobs in\n--- ./src/findlib.ml\n+++ ./src/findlib.ml\n@@ -66,9 +66,6 @@\n (fun command -> lexer & Lexing.from_string & run_and_read command)\n command\n \n-let run_and_read command =\n- Printf.ksprintf run_and_read command\n-\n let rec query name =\n try\n Hashtbl.find packages name\n@@ -135,7 +132,8 @@\n with Not_found -> s\n \n let list () =\n- List.map before_space (split_nl & run_and_read \"%s list\" ocamlfind)\n+ let cmd = Shell.quote_filename_if_needed ocamlfind ^ \" list\" in\n+ List.map before_space (split_nl & run_and_read cmd)\n \n (* The closure algorithm is easy because the dependencies are already closed\n and sorted for each package. We only have to make the union. We could also\n--- ./src/main.ml\n+++ ./src/main.ml\n@@ -162,6 +162,9 @@\n Tags.mem \"traverse\" tags\n || List.exists (Pathname.is_prefix path_name) !Options.include_dirs\n || List.exists (Pathname.is_prefix path_name) target_dirs)\n+ && ((* beware: !Options.build_dir is an absolute directory *)\n+ Pathname.normalize !Options.build_dir\n+ <> Pathname.normalize (Pathname.pwd/path_name))\n end\n end\n end\n--- ./src/my_std.ml\n+++ ./src/my_std.ml\n@@ -271,13 +271,107 @@\n try Array.iter (fun x -> if x = basename then raise Exit) a; false\n with Exit -> true\n \n+let command_plain = function\n+| [| |] -> 0\n+| margv ->\n+ let rec waitpid a b =\n+ match Unix.waitpid a b with\n+ | exception (Unix.Unix_error(Unix.EINTR,_,_)) -> waitpid a b\n+ | x -> x\n+ in\n+ let pid = Unix.(create_process margv.(0) margv stdin stdout stderr) in\n+ let pid', process_status = waitpid [] pid in\n+ assert (pid = pid');\n+ match process_status with\n+ | Unix.WEXITED n -> n\n+ | Unix.WSIGNALED _ -> 2 (* like OCaml's uncaught exceptions *)\n+ | Unix.WSTOPPED _ -> 127\n+\n+(* can't use Lexers because of circular dependency *)\n+let split_path_win str =\n+ let rec aux pos =\n+ try\n+ let i = String.index_from str pos ';' in\n+ let len = i - pos in\n+ if len = 0 then\n+ aux (succ i)\n+ else\n+ String.sub str pos (i - pos) :: aux (succ i)\n+ with Not_found | Invalid_argument _ ->\n+ let len = String.length str - pos in\n+ if len = 0 then [] else [String.sub str pos len]\n+ in\n+ aux 0\n+\n+let windows_shell = lazy begin\n+ let rec iter = function\n+ | [] -> [| \"bash.exe\" ; \"--norc\" ; \"--noprofile\" |]\n+ | hd::tl ->\n+ let dash = Filename.concat hd \"dash.exe\" in\n+ if Sys.file_exists dash then [|dash|] else\n+ let bash = Filename.concat hd \"bash.exe\" in\n+ if Sys.file_exists bash = false then iter tl else\n+ (* if sh.exe and bash.exe exist in the same dir, choose sh.exe *)\n+ let sh = Filename.concat hd \"sh.exe\" in\n+ if Sys.file_exists sh then [|sh|] else [|bash ; \"--norc\" ; \"--noprofile\"|]\n+ in\n+ split_path_win (try Sys.getenv \"PATH\" with Not_found -> \"\") |> iter\n+end\n+\n+let prep_windows_cmd cmd =\n+ (* workaround known ocaml bug, remove later *)\n+ if String.contains cmd '\\t' && String.contains cmd ' ' = false then\n+ \" \" ^ cmd\n+ else\n+ cmd\n+\n+let run_with_shell = function\n+| \"\" -> 0\n+| cmd ->\n+ let cmd = prep_windows_cmd cmd in\n+ let shell = Lazy.force windows_shell in\n+ let qlen = Filename.quote cmd |> String.length in\n+ (* old versions of dash had problems with bs *)\n+ try\n+ if qlen < 7_900 then\n+ command_plain (Array.append shell [| \"-ec\" ; cmd |])\n+ else begin\n+ (* it can still work, if the called command is a cygwin tool *)\n+ let ch_closed = ref false in\n+ let file_deleted = ref false in\n+ let fln,ch =\n+ Filename.open_temp_file\n+ ~mode:[Open_binary]\n+ \"ocamlbuildtmp\"\n+ \".sh\"\n+ in\n+ try\n+ let f_slash = String.map ( fun x -> if x = '\\\\' then '/' else x ) fln in\n+ output_string ch cmd;\n+ ch_closed:= true;\n+ close_out ch;\n+ let ret = command_plain (Array.append shell [| \"-e\" ; f_slash |]) in\n+ file_deleted:= true;\n+ Sys.remove fln;\n+ ret\n+ with\n+ | x ->\n+ if !ch_closed = false then\n+ close_out_noerr ch;\n+ if !file_deleted = false then\n+ (try Sys.remove fln with _ -> ());\n+ raise x\n+ end\n+ with\n+ | (Unix.Unix_error _) as x ->\n+ (* Sys.command doesn't raise an exception, so run_with_shell also won't\n+ raise *)\n+ Printexc.to_string x ^ \":\" ^ cmd |> prerr_endline;\n+ 1\n+\n let sys_command =\n- match Sys.os_type with\n- | \"Win32\" -> fun cmd ->\n- if cmd = \"\" then 0 else\n- let cmd = \"bash --norc -c \" ^ Filename.quote cmd in\n- Sys.command cmd\n- | _ -> fun cmd -> if cmd = \"\" then 0 else Sys.command cmd\n+ if Sys.win32 then run_with_shell\n+ else fun cmd -> if cmd = \"\" then 0 else Sys.command cmd\n \n (* FIXME warning fix and use Filename.concat *)\n let filename_concat x y =\n--- ./src/my_std.mli\n+++ ./src/my_std.mli\n@@ -69,3 +69,6 @@\n \n val split_ocaml_version : (int * int * int * string) option\n (** (major, minor, patchlevel, rest) *)\n+\n+val windows_shell : string array Lazy.t\n+val prep_windows_cmd : string -> string\n--- ./src/ocamlbuild_executor.ml\n+++ ./src/ocamlbuild_executor.ml\n@@ -34,6 +34,8 @@\n job_stdin : out_channel;\n job_stderr : in_channel;\n job_buffer : Buffer.t;\n+ job_pid : int;\n+ job_tmp_file: string option;\n mutable job_dying : bool;\n };;\n \n@@ -76,6 +78,61 @@\n in\n loop 0\n ;;\n+\n+let open_process_full_win cmd env =\n+ let (in_read, in_write) = Unix.pipe () in\n+ let (out_read, out_write) = Unix.pipe () in\n+ let (err_read, err_write) = Unix.pipe () in\n+ Unix.set_close_on_exec in_read;\n+ Unix.set_close_on_exec out_write;\n+ Unix.set_close_on_exec err_read;\n+ let inchan = Unix.in_channel_of_descr in_read in\n+ let outchan = Unix.out_channel_of_descr out_write in\n+ let errchan = Unix.in_channel_of_descr err_read in\n+ let shell = Lazy.force Ocamlbuild_pack.My_std.windows_shell in\n+ let test_cmd =\n+ String.concat \" \" (List.map Filename.quote (Array.to_list shell)) ^\n+ \"-ec \" ^\n+ Filename.quote (Ocamlbuild_pack.My_std.prep_windows_cmd cmd) in\n+ let argv,tmp_file =\n+ if String.length test_cmd < 7_900 then\n+ Array.append\n+ shell\n+ [| \"-ec\" ; Ocamlbuild_pack.My_std.prep_windows_cmd cmd |],None\n+ else\n+ let fln,ch = Filename.open_temp_file ~mode:[Open_binary] \"ocamlbuild\" \".sh\" in\n+ output_string ch (Ocamlbuild_pack.My_std.prep_windows_cmd cmd);\n+ close_out ch;\n+ let fln' = String.map (function '\\\\' -> '/' | c -> c) fln in\n+ Array.append\n+ shell\n+ [| \"-c\" ; fln' |], Some fln in\n+ let pid =\n+ Unix.create_process_env argv.(0) argv env out_read in_write err_write in\n+ Unix.close out_read;\n+ Unix.close in_write;\n+ Unix.close err_write;\n+ (pid, inchan, outchan, errchan,tmp_file)\n+\n+let close_process_full_win (pid,inchan, outchan, errchan, tmp_file) =\n+ let delete tmp_file =\n+ match tmp_file with\n+ | None -> ()\n+ | Some x -> try Sys.remove x with Sys_error _ -> () in\n+ let tmp_file_deleted = ref false in\n+ try\n+ close_in inchan;\n+ close_out outchan;\n+ close_in errchan;\n+ let res = snd(Unix.waitpid [] pid) in\n+ tmp_file_deleted := true;\n+ delete tmp_file;\n+ res\n+ with\n+ | x when tmp_file <> None && !tmp_file_deleted = false ->\n+ delete tmp_file;\n+ raise x\n+\n (* ***)\n (*** execute *)\n (* XXX: Add test for non reentrancy *)\n@@ -130,10 +187,16 @@\n (*** add_job *)\n let add_job cmd rest result id =\n (*display begin fun oc -> fp oc \"Job %a is %s\\n%!\" print_job_id id cmd; end;*)\n- let (stdout', stdin', stderr') = open_process_full cmd env in\n+ let (pid,stdout', stdin', stderr', tmp_file) =\n+ if Sys.win32 then open_process_full_win cmd env else\n+ let a,b,c = open_process_full cmd env in\n+ -1,a,b,c,None\n+ in\n incr jobs_active;\n- set_nonblock (doi stdout');\n- set_nonblock (doi stderr');\n+ if not Sys.win32 then (\n+ set_nonblock (doi stdout');\n+ set_nonblock (doi stderr');\n+ );\n let job =\n { job_id = id;\n job_command = cmd;\n@@ -143,7 +206,9 @@\n job_stdin = stdin';\n job_stderr = stderr';\n job_buffer = Buffer.create 1024;\n- job_dying = false }\n+ job_dying = false;\n+ job_tmp_file = tmp_file;\n+ job_pid = pid }\n in\n outputs := FDM.add (doi stdout') job (FDM.add (doi stderr') job !outputs);\n jobs := JS.add job !jobs;\n@@ -199,6 +264,7 @@\n try\n read fd u 0 (Bytes.length u)\n with\n+ | Unix.Unix_error(Unix.EPIPE,_,_) when Sys.win32 -> 0\n | Unix.Unix_error(e,_,_) ->\n let msg = error_message e in\n display (fun oc -> fp oc\n@@ -241,14 +307,19 @@\n decr jobs_active;\n \n (* PR#5371: we would get EAGAIN below otherwise *)\n- clear_nonblock (doi job.job_stdout);\n- clear_nonblock (doi job.job_stderr);\n-\n+ if not Sys.win32 then (\n+ clear_nonblock (doi job.job_stdout);\n+ clear_nonblock (doi job.job_stderr);\n+ );\n do_read ~loop:true (doi job.job_stdout) job;\n do_read ~loop:true (doi job.job_stderr) job;\n outputs := FDM.remove (doi job.job_stdout) (FDM.remove (doi job.job_stderr) !outputs);\n jobs := JS.remove job !jobs;\n- let status = close_process_full (job.job_stdout, job.job_stdin, job.job_stderr) in\n+ let status =\n+ if Sys.win32 then\n+ close_process_full_win (job.job_pid, job.job_stdout, job.job_stdin, job.job_stderr, job.job_tmp_file)\n+ else\n+ close_process_full (job.job_stdout, job.job_stdin, job.job_stderr) in\n \n let shown = ref false in\n \n--- ./src/ocamlbuild_unix_plugin.ml\n+++ ./src/ocamlbuild_unix_plugin.ml\n@@ -48,12 +48,22 @@\n end\n \n let run_and_open s kont =\n+ let s_orig = s in\n+ let s =\n+ (* Be consistent! My_unix.run_and_open uses My_std.sys_command and\n+ sys_command uses bash. *)\n+ if Sys.win32 = false then s else\n+ let l = match Lazy.force My_std.windows_shell |> Array.to_list with\n+ | hd::tl -> (Filename.quote hd)::tl\n+ | _ -> assert false in\n+ \"\\\"\" ^ (String.concat \" \" l) ^ \" -ec \" ^ Filename.quote (\" \" ^ s) ^ \"\\\"\"\n+ in\n let ic = Unix.open_process_in s in\n let close () =\n match Unix.close_process_in ic with\n | Unix.WEXITED 0 -> ()\n | Unix.WEXITED _ | Unix.WSIGNALED _ | Unix.WSTOPPED _ ->\n- failwith (Printf.sprintf \"Error while running: %s\" s) in\n+ failwith (Printf.sprintf \"Error while running: %s\" s_orig) in\n let res = try\n kont ic\n with e -> (close (); raise e)\n--- ./src/options.ml\n+++ ./src/options.ml\n@@ -174,11 +174,24 @@\n build_dir := Filename.concat (Sys.getcwd ()) s\n else\n build_dir := s\n+\n+let slashify =\n+ if Sys.win32 then fun p -> String.map (function '\\\\' -> '/' | x -> x) p\n+ else fun p ->p\n+\n+let sb () =\n+ match Sys.os_type with\n+ | \"Win32\" ->\n+ (try set_binary_mode_out stdout true with _ -> ());\n+ | _ -> ()\n+\n+\n let spec = ref (\n let print_version () =\n+ sb ();\n Printf.printf \"ocamlbuild %s\\n%!\" Ocamlbuild_config.version; raise Exit_OK\n in\n- let print_vnum () = print_endline Ocamlbuild_config.version; raise Exit_OK in\n+ let print_vnum () = sb (); print_endline Ocamlbuild_config.version; raise Exit_OK in\n Arg.align\n [\n \"-version\", Unit print_version , \" Display the version\";\n@@ -257,8 +270,8 @@\n \"-build-dir\", String set_build_dir, \"<path> Set build directory (implies no-links)\";\n \"-install-lib-dir\", Set_string Ocamlbuild_where.libdir, \"<path> Set the install library directory\";\n \"-install-bin-dir\", Set_string Ocamlbuild_where.bindir, \"<path> Set the install binary directory\";\n- \"-where\", Unit (fun () -> print_endline !Ocamlbuild_where.libdir; raise Exit_OK), \" Display the install library directory\";\n- \"-which\", String (fun cmd -> print_endline (find_tool cmd); raise Exit_OK), \"<command> Display path to the tool command\";\n+ \"-where\", Unit (fun () -> sb (); print_endline (slashify !Ocamlbuild_where.libdir); raise Exit_OK), \" Display the install library directory\";\n+ \"-which\", String (fun cmd -> sb (); print_endline (slashify (find_tool cmd)); raise Exit_OK), \"<command> Display path to the tool command\";\n \"-ocamlc\", set_cmd ocamlc, \"<command> Set the OCaml bytecode compiler\";\n \"-plugin-ocamlc\", set_cmd plugin_ocamlc, \"<command> Set the OCaml bytecode compiler \\\n used when building myocamlbuild.ml (only)\";\n--- ./src/pathname.ml\n+++ ./src/pathname.ml\n@@ -84,6 +84,26 @@\n | x :: xs -> x :: normalize_list xs\n \n let normalize x =\n+ let x =\n+ if Sys.win32 = false then\n+ x\n+ else\n+ let len = String.length x in\n+ let b = Bytes.create len in\n+ for i = 0 to pred len do\n+ match x.[i] with\n+ | '\\\\' -> Bytes.set b i '/'\n+ | c -> Bytes.set b i c\n+ done;\n+ if len > 1 then (\n+ let c1 = Bytes.get b 0 in\n+ let c2 = Bytes.get b 1 in\n+ if c2 = ':' && c1 >= 'a' && c1 <= 'z' &&\n+ ( len = 2 || Bytes.get b 2 = '/') then\n+ Bytes.set b 0 (Char.uppercase_ascii c1)\n+ );\n+ Bytes.unsafe_to_string b\n+ in\n if Glob.eval not_normal_form_re x then\n let root, paths = split x in\n join root (normalize_list paths)\n--- ./src/shell.ml\n+++ ./src/shell.ml\n@@ -24,12 +24,26 @@\n | 'a'..'z' | 'A'..'Z' | '0'..'9' | '.' | '-' | '/' | '_' | ':' | '@' | '+' | ',' -> loop (pos + 1)\n | _ -> false in\n loop 0\n+\n+let generic_quote quotequote s =\n+ let l = String.length s in\n+ let b = Buffer.create (l + 20) in\n+ Buffer.add_char b '\\'';\n+ for i = 0 to l - 1 do\n+ if s.[i] = '\\''\n+ then Buffer.add_string b quotequote\n+ else Buffer.add_char b s.[i]\n+ done;\n+ Buffer.add_char b '\\'';\n+ Buffer.contents b\n+let unix_quote = generic_quote \"'\\\\''\"\n+\n let quote_filename_if_needed s =\n if is_simple_filename s then s\n (* We should probably be using [Filename.unix_quote] except that function\n * isn't exported. Users on Windows will have to live with not being able to\n * install OCaml into c:\\o'caml. Too bad. *)\n- else if Sys.os_type = \"Win32\" then Printf.sprintf \"'%s'\" s\n+ else if Sys.os_type = \"Win32\" then unix_quote s\n else Filename.quote s\n let chdir dir =\n reset_filesys_cache ();\n@@ -37,7 +51,7 @@\n let run args target =\n reset_readdir_cache ();\n let cmd = String.concat \" \" (List.map quote_filename_if_needed args) in\n- if !*My_unix.is_degraded || Sys.os_type = \"Win32\" then\n+ if !*My_unix.is_degraded then\n begin\n Log.event cmd target Tags.empty;\n let st = sys_command cmd in\n"
}
],
"opam": {
"name": "ocamlbuild",
"version": "0.12.0",
"opam":
"opam-version: \"2.0\"\nname: \"ocamlbuild\"\nversion: \"0.12.0\"\nsynopsis:\n \"OCamlbuild is a build system with builtin rules to easily build most OCaml projects.\"\nmaintainer: \"Gabriel Scherer <gabriel.scherer@gmail.com>\"\nauthors: [\"Nicolas Pouillard\" \"Berke Durak\"]\nlicense: \"LGPL-2 with OCaml linking exception\"\nhomepage: \"https://github.com/ocaml/ocamlbuild/\"\ndoc: \"https://github.com/ocaml/ocamlbuild/blob/master/manual/manual.adoc\"\nbug-reports: \"https://github.com/ocaml/ocamlbuild/issues\"\ndepends: [\n \"ocaml\" {>= \"4.03\" & < \"4.08.0\"}\n]\nconflicts: [\n \"base-ocamlbuild\"\n \"ocamlfind\" {< \"1.6.2\"}\n]\nbuild: [\n [\n make\n \"-f\"\n \"configure.make\"\n \"all\"\n \"OCAMLBUILD_PREFIX=%{prefix}%\"\n \"OCAMLBUILD_BINDIR=%{bin}%\"\n \"OCAMLBUILD_LIBDIR=%{lib}%\"\n \"OCAMLBUILD_MANDIR=%{man}%\"\n \"OCAML_NATIVE=%{ocaml:native}%\"\n \"OCAML_NATIVE_TOOLS=%{ocaml:native}%\"\n ]\n [make \"check-if-preinstalled\" \"all\" \"opam-install\"]\n]\ndev-repo: \"git+https://github.com/ocaml/ocamlbuild.git\"\nurl {\n src: \"https://github.com/ocaml/ocamlbuild/archive/0.12.0.tar.gz\"\n checksum: \"md5=442baa19470bd49150f153122e22907b\"\n}",
"override": {
"build": [
[
"bash", "-c",
"#{os == 'windows' ? 'patch -p1 < ocamlbuild-0.12.0.patch' : 'true'}"
],
[
"make", "-f", "configure.make", "all",
"OCAMLBUILD_PREFIX=#{self.install}",
"OCAMLBUILD_BINDIR=#{self.bin}",
"OCAMLBUILD_LIBDIR=#{self.lib}",
"OCAMLBUILD_MANDIR=#{self.man}", "OCAMLBUILD_NATIVE=true",
"OCAMLBUILD_NATIVE_TOOLS=true"
],
[
"make", "check-if-preinstalled", "all",
"#{os == 'windows' ? 'install' : 'opam-install'}"
]
]
}
}
},
"dependencies": [ "@esy-ocaml/substs@0.0.1", "ocaml@4.6.7" ]
},
"@opam/ocaml-migrate-parsetree@opam:1.1.0": {
"record": {
"name": "@opam/ocaml-migrate-parsetree",
"version": "opam:1.1.0",
"source":
"archive:https://github.com/ocaml-ppx/ocaml-migrate-parsetree/releases/download/v1.1.0/ocaml-migrate-parsetree-1.1.0.tbz#md5:7dd4808e27af98065f63604c9658d311",
"files": [],
"opam": {
"name": "ocaml-migrate-parsetree",
"version": "1.1.0",
"opam":
"opam-version: \"2.0\"\nname: \"ocaml-migrate-parsetree\"\nversion: \"1.1.0\"\nsynopsis: \"\"\ndescription: \"\"\"\nConvert OCaml parsetrees between different versions \n\nThis library converts parsetrees, outcometree and ast mappers between different OCaml versions.\nHigh-level functions help making PPX rewriters independent of a compiler version.\"\"\"\nmaintainer: \"frederic.bour@lakaban.net\"\nauthors: [\n \"Frédéric Bour <frederic.bour@lakaban.net>\"\n \"Jérémie Dimino <jeremie@dimino.org>\"\n]\nlicense: \"LGPL-2.1\"\ntags: [\"syntax\" \"org:ocamllabs\"]\nhomepage: \"https://github.com/ocaml-ppx/ocaml-migrate-parsetree\"\ndoc: \"https://ocaml-ppx.github.io/ocaml-migrate-parsetree/\"\nbug-reports: \"https://github.com/ocaml-ppx/ocaml-migrate-parsetree/issues\"\ndepends: [\n \"result\"\n \"dune\" {build}\n \"ocaml\" {>= \"4.02.0\"}\n]\nbuild: [\"jbuilder\" \"build\" \"-p\" name \"-j\" jobs]\ndev-repo: \"git+https://github.com/ocaml-ppx/ocaml-migrate-parsetree.git\"\nurl {\n src:\n \"https://github.com/ocaml-ppx/ocaml-migrate-parsetree/releases/download/v1.1.0/ocaml-migrate-parsetree-1.1.0.tbz\"\n checksum: \"md5=7dd4808e27af98065f63604c9658d311\"\n}",
"override": null
}
},
"dependencies": [
"@esy-ocaml/substs@0.0.1", "@opam/dune@opam:1.4.0",
"@opam/result@opam:1.3", "ocaml@4.6.7"
]
},
"@opam/merlin-extend@opam:0.3": {
"record": {
"name": "@opam/merlin-extend",
"version": "opam:0.3",
"source":
"archive:https://github.com/let-def/merlin-extend/archive/v0.3.tar.gz#md5:9c6dfd4f53328f02f12fcc265f4e2dda",
"files": [
{
"name": "merlin-extend-winfix.patch",
"content":
"--- ./extend_helper.ml\n+++ ./extend_helper.ml\n@@ -1,13 +1,6 @@\n-(*pp cppo -V OCAML:`ocamlc -version` *)\n open Parsetree\n open Extend_protocol\n \n-#if OCAML_VERSION < (4, 3, 0)\n-# define CONST_STRING Asttypes.Const_string\n-#else\n-# define CONST_STRING Parsetree.Pconst_string\n-#endif\n-\n (** Default implementation for [Reader_def.print_outcome] using\n [Oprint] from compiler-libs *)\n let print_outcome_using_oprint ppf = function\n@@ -28,7 +21,7 @@\n pstr_loc = Location.none;\n pstr_desc = Pstr_eval ({\n pexp_loc = Location.none;\n- pexp_desc = Pexp_constant (CONST_STRING (msg, None));\n+ pexp_desc = Pexp_constant (Parsetree.Pconst_string (msg, None));\n pexp_attributes = [];\n }, []);\n }]\n@@ -112,7 +105,7 @@\n let msg = match payload with\n | PStr [{\n pstr_desc = Pstr_eval ({\n- pexp_desc = Pexp_constant (CONST_STRING (msg, _));\n+ pexp_desc = Pexp_constant (Parsetree.Pconst_string (msg, _));\n }, _);\n }] -> msg\n | _ -> \"Warning: extension produced an incorrect syntax-error node\"\n"
}
],
"opam": {
"name": "merlin-extend",
"version": "0.3",
"opam":
"opam-version: \"2.0\"\nname: \"merlin-extend\"\nversion: \"0.3\"\nsynopsis: \"A protocol to provide custom frontend to Merlin\"\ndescription: \"\"\"\nThis protocol allows to replace the OCaml frontend of Merlin.\nIt extends what used to be done with the `-pp' flag to handle a few more cases.\"\"\"\nmaintainer: \"Frederic Bour <frederic.bour@lakaban.net>\"\nauthors: \"Frederic Bour <frederic.bour@lakaban.net>\"\nlicense: \"MIT\"\nhomepage: \"https://github.com/let-def/merlin-extend\"\nbug-reports: \"https://github.com/let-def/merlin-extend\"\ndepends: [\n \"ocaml\" {>= \"4.02.3\"}\n \"ocamlfind\" {build}\n \"cppo\" {build}\n]\nflags: light-uninstall\nbuild: make\ninstall: [make \"install\"]\nremove: [\"ocamlfind\" \"remove\" \"merlin_extend\"]\ndev-repo: \"git+https://github.com/let-def/merlin-extend.git\"\nurl {\n src: \"https://github.com/let-def/merlin-extend/archive/v0.3.tar.gz\"\n checksum: \"md5=9c6dfd4f53328f02f12fcc265f4e2dda\"\n}",
"override": {
"build": [
[
"bash", "-c",
"#{os == 'windows' ? 'patch -p1 < merlin-extend-winfix.patch' : 'true'}"
],
[ "make" ]
]
}
}
},
"dependencies": [
"@esy-ocaml/substs@0.0.1", "@opam/cppo@opam:1.6.5",
"@opam/ocamlfind@opam:1.8.0", "ocaml@4.6.7"
]
},
"@opam/merlin@opam:3.2.2": {
"record": {
"name": "@opam/merlin",
"version": "opam:3.2.2",
"source":
"archive:https://github.com/ocaml/merlin/releases/download/v3.2.2/merlin-v3.2.2.tbz#md5:ede35b65f8ac9c440cfade5445662c54",
"files": [],
"opam": {
"name": "merlin",
"version": "3.2.2",
"opam":
"opam-version: \"2.0\"\nname: \"merlin\"\nversion: \"3.2.2\"\nsynopsis: \"Installation with Opam\"\ndescription: \"\"\"\nIf you have a working [Opam](https://opam.ocaml.org/) installation, Merlin is only two commands away:\n\n```shell\nopam install merlin\nopam user-setup install\n```\n\n[opam-user-setup](https://github.com/OCamlPro/opam-user-setup) takes care of configuring Emacs and Vim to make best use of your current install.\n\nYou can also [configure the editor](#editor-setup) yourself, if you prefer.\"\"\"\nmaintainer: \"defree@gmail.com\"\nauthors: \"The Merlin team\"\nhomepage: \"https://github.com/ocaml/merlin\"\nbug-reports: \"https://github.com/ocaml/merlin/issues\"\ndepends: [\n \"ocaml\" {>= \"4.02.1\" & < \"4.08\"}\n \"dune\" {build}\n \"ocamlfind\" {>= \"1.5.2\"}\n \"yojson\"\n \"craml\" {with-test}\n]\nbuild: [\n [\"dune\" \"subst\"] {pinned}\n [\"dune\" \"build\" \"-p\" name \"-j\" jobs]\n]\npost-messages:\n \"\"\"\nmerlin installed.\n\nQuick setup for VIM\n-------------------\nAppend this to your .vimrc to add merlin to vim's runtime-path:\n let g:opamshare = substitute(system('opam config var share'),'\\\\n$','','''')\n execute \"set rtp+=\" . g:opamshare . \"/merlin/vim\"\n\nAlso run the following line in vim to index the documentation:\n :execute \"helptags \" . g:opamshare . \"/merlin/vim/doc\"\n\nQuick setup for EMACS\n-------------------\nAdd opam emacs directory to your load-path by appending this to your .emacs:\n (let ((opam-share (ignore-errors (car (process-lines \"opam\" \"config\" \"var\" \"share\")))))\n (when (and opam-share (file-directory-p opam-share))\n ;; Register Merlin\n (add-to-list 'load-path (expand-file-name \"emacs/site-lisp\" opam-share))\n (autoload 'merlin-mode \"merlin\" nil t nil)\n ;; Automatically start it in OCaml buffers\n (add-hook 'tuareg-mode-hook 'merlin-mode t)\n (add-hook 'caml-mode-hook 'merlin-mode t)\n ;; Use opam switch to lookup ocamlmerlin binary\n (setq merlin-command 'opam)))\n\nTake a look at https://github.com/ocaml/merlin for more information\n\nQuick setup with opam-user-setup\n--------------------------------\n\nOpam-user-setup support Merlin.\n\n $ opam user-setup install\n\nshould take care of basic setup.\nSee https://github.com/OCamlPro/opam-user-setup\"\"\"\n {success & !user-setup:installed}\ndev-repo: \"git+https://github.com/ocaml/merlin.git\"\nurl {\n src:\n \"https://github.com/ocaml/merlin/releases/download/v3.2.2/merlin-v3.2.2.tbz\"\n checksum: \"md5=ede35b65f8ac9c440cfade5445662c54\"\n}",
"override": null
}
},
"dependencies": [
"@esy-ocaml/substs@0.0.1", "@opam/dune@opam:1.4.0",
"@opam/ocamlfind@opam:1.8.0", "@opam/yojson@opam:1.4.1",
"ocaml@4.6.7"
]
},
"@opam/menhir@opam:20181006": {
"record": {
"name": "@opam/menhir",
"version": "opam:20181006",
"source":
"archive:http://gallium.inria.fr/~fpottier/menhir/menhir-20181006.tar.gz#md5:d2174b0d4bd8feb66a7484be6f1eed14",
"files": [],
"opam": {
"name": "menhir",
"version": "20181006",
"opam":
"opam-version: \"2.0\"\nname: \"menhir\"\nversion: \"20181006\"\nsynopsis: \"LR(1) parser generator\"\nmaintainer: \"francois.pottier@inria.fr\"\nauthors: [\n \"François Pottier <francois.pottier@inria.fr>\"\n \"Yann Régis-Gianas <yrg@pps.univ-paris-diderot.fr>\"\n]\nhomepage: \"http://gallium.inria.fr/~fpottier/menhir/\"\nbug-reports: \"menhir@inria.fr\"\ndepends: [\n \"ocaml\" {>= \"4.02\"}\n \"ocamlfind\" {build}\n \"ocamlbuild\" {build}\n]\nbuild: [\n make\n \"-f\"\n \"Makefile\"\n \"PREFIX=%{prefix}%\"\n \"USE_OCAMLFIND=true\"\n \"docdir=%{doc}%/menhir\"\n \"libdir=%{lib}%/menhir\"\n \"mandir=%{man}%/man1\"\n]\ninstall: [\n make\n \"-f\"\n \"Makefile\"\n \"install\"\n \"PREFIX=%{prefix}%\"\n \"docdir=%{doc}%/menhir\"\n \"libdir=%{lib}%/menhir\"\n \"mandir=%{man}%/man1\"\n]\nremove: [\n make\n \"-f\"\n \"Makefile\"\n \"uninstall\"\n \"PREFIX=%{prefix}%\"\n \"docdir=%{doc}%/menhir\"\n \"libdir=%{lib}%/menhir\"\n \"mandir=%{man}%/man1\"\n]\ndev-repo: \"git+https://gitlab.inria.fr/fpottier/menhir.git\"\nurl {\n src: \"http://gallium.inria.fr/~fpottier/menhir/menhir-20181006.tar.gz\"\n checksum: \"md5=d2174b0d4bd8feb66a7484be6f1eed14\"\n}",
"override": null
}
},
"dependencies": [
"@esy-ocaml/substs@0.0.1", "@opam/ocamlbuild@opam:0.12.0",
"@opam/ocamlfind@opam:1.8.0", "ocaml@4.6.7"
]
},
"@opam/lwt_react@opam:1.1.1": {
"record": {
"name": "@opam/lwt_react",
"version": "opam:1.1.1",
"source":
"archive:https://github.com/ocsigen/lwt/archive/4.0.0.tar.gz#md5:3bbde866884e32cc7a9d9cbd1e52bde3",
"files": [],
"opam": {
"name": "lwt_react",
"version": "1.1.1",
"opam":
"opam-version: \"2.0\"\nname: \"lwt_react\"\nversion: \"1.1.1\"\nsynopsis: \"Helpers for using React with Lwt\"\nmaintainer: [\n \"Anton Bachin <antonbachin@yahoo.com>\"\n \"Mauricio Fernandez <mfp@acm.org>\"\n \"Simon Cruanes <simon.cruanes.2007@m4x.org>\"\n]\nauthors: \"Jérémie Dimino\"\nlicense: \"LGPL with OpenSSL linking exception\"\nhomepage: \"https://github.com/ocsigen/lwt\"\ndoc: \"https://ocsigen.org/lwt/api/Lwt_react\"\nbug-reports: \"https://github.com/ocsigen/lwt/issues\"\ndepends: [\n \"ocaml\"\n \"jbuilder\" {build & >= \"1.0+beta14\"}\n \"lwt\" {>= \"3.0.0\"}\n \"react\" {>= \"1.0.0\"}\n]\nbuild: [\n [\"jbuilder\" \"build\" \"-p\" name \"-j\" jobs]\n [\"jbuilder\" \"runtest\" \"-p\" name] {with-test}\n]\ndev-repo: \"git+https://github.com/ocsigen/lwt.git\"\nurl {\n src: \"https://github.com/ocsigen/lwt/archive/4.0.0.tar.gz\"\n checksum: \"md5=3bbde866884e32cc7a9d9cbd1e52bde3\"\n}",
"override": null
}
},
"dependencies": [
"@esy-ocaml/substs@0.0.1", "@opam/jbuilder@opam:transition",
"@opam/lwt@opam:4.1.0", "@opam/react@opam:1.2.1", "ocaml@4.6.7"
]
},
"@opam/lwt_log@opam:1.1.0": {
"record": {
"name": "@opam/lwt_log",
"version": "opam:1.1.0",
"source":
"archive:https://github.com/aantron/lwt_log/archive/1.1.0.tar.gz#md5:92142135d01a4d7e805990cc98653d55",
"files": [],
"opam": {
"name": "lwt_log",
"version": "1.1.0",
"opam":
"opam-version: \"2.0\"\nname: \"lwt_log\"\nversion: \"1.1.0\"\nsynopsis: \"Lwt logging library (deprecated)\"\nmaintainer: \"Anton Bachin <antonbachin@yahoo.com>\"\nauthors: [\"Shawn Wagner\" \"Jérémie Dimino\"]\nlicense: \"LGPL\"\nhomepage: \"https://github.com/aantron/lwt_log\"\ndoc:\n \"https://github.com/aantron/lwt_log/blob/master/src/core/lwt_log_core.mli\"\nbug-reports: \"https://github.com/aantron/lwt_log/issues\"\ndepends: [\n \"ocaml\"\n \"jbuilder\" {build & >= \"1.0+beta10\"}\n \"lwt\" {>= \"4.0.0\"}\n]\nbuild: [\"jbuilder\" \"build\" \"-p\" name \"-j\" jobs]\ndev-repo: \"git+https://github.com/aantron/lwt_log.git\"\nurl {\n src: \"https://github.com/aantron/lwt_log/archive/1.1.0.tar.gz\"\n checksum: \"md5=92142135d01a4d7e805990cc98653d55\"\n}",
"override": null
}
},
"dependencies": [
"@esy-ocaml/substs@0.0.1", "@opam/jbuilder@opam:transition",
"@opam/lwt@opam:4.1.0", "ocaml@4.6.7"
]
},
"@opam/lwt@opam:4.1.0": {
"record": {
"name": "@opam/lwt",
"version": "opam:4.1.0",
"source":
"archive:https://github.com/ocsigen/lwt/archive/4.1.0.tar.gz#md5:e919bee206f18b3d49250ecf9584fde7",
"files": [],
"opam": {
"name": "lwt",
"version": "4.1.0",
"opam":
"opam-version: \"2.0\"\nname: \"lwt\"\nversion: \"4.1.0\"\nsynopsis: \"Promises, concurrency, and parallelized I/O\"\ndescription: \"\"\"\nA promise is a value that may become determined in the future.\n\nLwt provides typed, composable promises. Promises that are resolved by I/O are\nresolved by Lwt in parallel.\n\nMeanwhile, OCaml code, including code creating and waiting on promises, runs in\na single thread by default. This reduces the need for locks or other\nsynchronization primitives. Code can be run in parallel on an opt-in basis.\"\"\"\nmaintainer: [\n \"Anton Bachin <antonbachin@yahoo.com>\"\n \"Mauricio Fernandez <mfp@acm.org>\"\n \"Simon Cruanes <simon.cruanes.2007@m4x.org>\"\n]\nauthors: [\"Jérôme Vouillon\" \"Jérémie Dimino\"]\nlicense: \"LGPL with OpenSSL linking exception\"\nhomepage: \"https://github.com/ocsigen/lwt\"\ndoc: \"https://ocsigen.org/lwt/manual/\"\nbug-reports: \"https://github.com/ocsigen/lwt/issues\"\ndepends: [\n \"ocaml\" {>= \"4.02.0\"}\n \"cppo\" {build & >= \"1.1.0\"}\n \"jbuilder\" {build & >= \"1.0+beta14\"}\n \"ocamlfind\" {build & >= \"1.7.3-1\"}\n \"result\"\n]\ndepopts: [\"base-threads\" \"base-unix\" \"conf-libev\"]\nconflicts: [\n \"ocaml-variants\" {= \"4.02.1+BER\"}\n]\nbuild: [\n [\"ocaml\" \"src/util/configure.ml\" \"-use-libev\" \"%{conf-libev:installed}%\"]\n [\"jbuilder\" \"build\" \"-p\" name \"-j\" jobs]\n]\nmessages: [\n \"For the PPX, please install package lwt_ppx\" {!lwt_ppx:installed}\n \"For the Camlp4 syntax, please install package lwt_camlp4\"\n {camlp4:installed & !lwt_camlp4:installed}\n \"For Lwt_log and Lwt_daemon, please install package lwt_log\"\n {!lwt_log:installed}\n]\ndev-repo: \"git+https://github.com/ocsigen/lwt.git\"\nurl {\n src: \"https://github.com/ocsigen/lwt/archive/4.1.0.tar.gz\"\n checksum: \"md5=e919bee206f18b3d49250ecf9584fde7\"\n}",
"override": null
}
},
"dependencies": [
"@esy-ocaml/substs@0.0.1", "@opam/cppo@opam:1.6.5",
"@opam/jbuilder@opam:transition", "@opam/ocamlfind@opam:1.8.0",
"@opam/result@opam:1.3", "ocaml@4.6.7"
]
},
"@opam/lambda-term@opam:1.13": {
"record": {
"name": "@opam/lambda-term",
"version": "opam:1.13",
"source":
"archive:https://github.com/diml/lambda-term/releases/download/1.13/lambda-term-1.13.tbz#md5:c13826a97014d4d573b927b623c7e043",
"files": [
{
"name": "lambda-term-1.13.patch",
"content":
"--- ./src/lTerm_windows_stubs.c\n+++ ./src/lTerm_windows_stubs.c\n@@ -16,7 +16,6 @@\n \n #if defined(_WIN32) || defined(_WIN64)\n \n-#include <windows.h>\n #include <lwt_unix.h>\n \n /* +-----------------------------------------------------------------+\n@@ -140,15 +139,7 @@\n }\n }\n \n-CAMLprim value lt_windows_read_console_input_job(value val_fd)\n-{\n- LWT_UNIX_INIT_JOB(job, read_console_input, 0);\n- job->handle = Handle_val(val_fd);\n- job->error_code = 0;\n- CAMLreturn(lwt_unix_alloc_job(&(job->job)));\n-}\n-\n-static value result_read_console_input_result(struct job_read_console_input *job)\n+static value result_read_console_input(struct job_read_console_input *job)\n {\n INPUT_RECORD input;\n DWORD cks, bs;\n@@ -163,23 +154,23 @@\n win32_maperr(error_code);\n uerror(\"ReadConsoleInput\", Nothing);\n }\n- switch (input->EventType) {\n+ switch (input.EventType) {\n case KEY_EVENT: {\n result = caml_alloc(1, 0);\n x = caml_alloc_tuple(4);\n Field(result, 0) = x;\n- cks = input->Event.KeyEvent.dwControlKeyState;\n+ cks = input.Event.KeyEvent.dwControlKeyState;\n Field(x, 0) = Val_bool((cks & LEFT_CTRL_PRESSED) | (cks & RIGHT_CTRL_PRESSED));\n Field(x, 1) = Val_bool((cks & LEFT_ALT_PRESSED) | (cks & RIGHT_ALT_PRESSED));\n Field(x, 2) = Val_bool(cks & SHIFT_PRESSED);\n- code = input->Event.KeyEvent.wVirtualKeyCode;\n+ code = input.Event.KeyEvent.wVirtualKeyCode;\n for (i = 0; i < sizeof(code_table)/sizeof(code_table[0]); i++)\n if (code == code_table[i]) {\n Field(x, 3) = Val_int(i);\n CAMLreturn(result);\n }\n y = caml_alloc_tuple(1);\n- Field(y, 0) = Val_int(input->Event.KeyEvent.uChar.UnicodeChar);\n+ Field(y, 0) = Val_int(input.Event.KeyEvent.uChar.UnicodeChar);\n Field(x, 3) = y;\n CAMLreturn(result);\n }\n@@ -187,13 +178,13 @@\n result = caml_alloc(1, 1);\n x = caml_alloc_tuple(6);\n Field(result, 0) = x;\n- cks = input->Event.MouseEvent.dwControlKeyState;\n+ cks = input.Event.MouseEvent.dwControlKeyState;\n Field(x, 0) = Val_bool((cks & LEFT_CTRL_PRESSED) | (cks & RIGHT_CTRL_PRESSED));\n Field(x, 1) = Val_bool((cks & LEFT_ALT_PRESSED) | (cks & RIGHT_ALT_PRESSED));\n Field(x, 2) = Val_bool(cks & SHIFT_PRESSED);\n- Field(x, 4) = Val_int(input->Event.MouseEvent.dwMousePosition.Y);\n- Field(x, 5) = Val_int(input->Event.MouseEvent.dwMousePosition.X);\n- bs = input->Event.MouseEvent.dwButtonState;\n+ Field(x, 4) = Val_int(input.Event.MouseEvent.dwMousePosition.Y);\n+ Field(x, 5) = Val_int(input.Event.MouseEvent.dwMousePosition.X);\n+ bs = input.Event.MouseEvent.dwButtonState;\n if (bs & FROM_LEFT_1ST_BUTTON_PRESSED)\n Field(x, 3) = Val_int(0);\n else if (bs & FROM_LEFT_2ND_BUTTON_PRESSED)\n@@ -212,6 +203,14 @@\n CAMLreturn(Val_int(0));\n }\n \n+CAMLprim value lt_windows_read_console_input_job(value val_fd)\n+{\n+ LWT_UNIX_INIT_JOB(job, read_console_input, 0);\n+ job->handle = Handle_val(val_fd);\n+ job->error_code = 0;\n+ return (lwt_unix_alloc_job(&(job->job)));\n+}\n+\n /* +-----------------------------------------------------------------+\n | Console informations |\n +-----------------------------------------------------------------+ */\n"
}
],
"opam": {
"name": "lambda-term",
"version": "1.13",
"opam":
"opam-version: \"2.0\"\nname: \"lambda-term\"\nversion: \"1.13\"\nsynopsis: \"Terminal manipulation library for OCaml\"\ndescription: \"\"\"\nLambda-term is a cross-platform library for manipulating the terminal. It\nprovides an abstraction for keys, mouse events, colors, as well as a set of\nwidgets to write curses-like applications. The main objective of lambda-term is\nto provide a higher level functional interface to terminal manipulation than,\nfor example, ncurses, by providing a native OCaml interface instead of bindings\nto a C library. Lambda-term integrates with zed to provide text edition\nfacilities in console applications.\"\"\"\nmaintainer: \"jeremie@dimino.org\"\nauthors: \"Jérémie Dimino\"\nlicense: \"BSD3\"\nhomepage: \"https://github.com/diml/lambda-term\"\nbug-reports: \"https://github.com/diml/lambda-term/issues\"\ndepends: [\n \"ocaml\" {>= \"4.02.3\"}\n \"lwt\" {>= \"2.7.0\"}\n \"lwt_log\"\n \"react\"\n \"zed\" {>= \"1.2\"}\n \"camomile\" {>= \"0.8.6\"}\n \"lwt_react\"\n \"jbuilder\" {build & >= \"1.0+beta9\"}\n]\nbuild: [\n [\"jbuilder\" \"subst\" \"-p\" name] {pinned}\n [\"jbuilder\" \"build\" \"-p\" name \"-j\" jobs]\n [\"jbuilder\" \"runtest\" \"-p\" name \"-j\" jobs] {with-test}\n]\ndev-repo: \"git://github.com/diml/lambda-term.git\"\nurl {\n src:\n \"https://github.com/diml/lambda-term/releases/download/1.13/lambda-term-1.13.tbz\"\n checksum: \"md5=c13826a97014d4d573b927b623c7e043\"\n}",
"override": {
"build": [
[
"bash", "-c",
"#{os == 'windows' ? 'patch -p1 < lambda-term-1.13.patch' : 'true'}"
],
[ "jbuilder", "build", "-p", "lambda-term", "-j", "4" ]
]
}
}
},
"dependencies": [
"@esy-ocaml/substs@0.0.1", "@opam/camomile@opam:1.0.1",
"@opam/jbuilder@opam:transition", "@opam/lwt@opam:4.1.0",
"@opam/lwt_log@opam:1.1.0", "@opam/lwt_react@opam:1.1.1",
"@opam/react@opam:1.2.1", "@opam/zed@opam:1.6", "ocaml@4.6.7"
]
},
"@opam/jbuilder@opam:transition": {
"record": {
"name": "@opam/jbuilder",
"version": "opam:transition",
"source": "no-source:",
"files": [],
"opam": {
"name": "jbuilder",
"version": "transition",
"opam":
"opam-version: \"2.0\"\nname: \"jbuilder\"\nversion: \"transition\"\nsynopsis:\n \"This is a transition package, jbuilder is now named dune. Use the dune\"\ndescription: \"package instead.\"\nmaintainer: \"opensource@janestreet.com\"\nauthors: \"Jane Street Group, LLC <opensource@janestreet.com>\"\nlicense: \"MIT\"\nhomepage: \"https://github.com/ocaml/dune\"\nbug-reports: \"https://github.com/ocaml/dune/issues\"\ndepends: [\"ocaml\" \"dune\"]\npost-messages:\n \"Jbuilder has been renamed and the jbuilder package is now a transition package. Use the dune package instead.\"\ndev-repo: \"git+https://github.com/ocaml/dune.git\"",
"override": null
}
},
"dependencies": [
"@esy-ocaml/substs@0.0.1", "@opam/dune@opam:1.4.0", "ocaml@4.6.7"
]
},
"@opam/easy-format@opam:1.3.1": {
"record": {
"name": "@opam/easy-format",
"version": "opam:1.3.1",
"source":
"archive:https://github.com/mjambon/easy-format/archive/v1.3.1.tar.gz#md5:4e163700fb88fdcd6b8976c3a216c8ea",
"files": [],
"opam": {
"name": "easy-format",
"version": "1.3.1",
"opam":
"opam-version: \"2.0\"\nname: \"easy-format\"\nversion: \"1.3.1\"\nsynopsis:\n \"High-level and functional interface to the Format module of the OCaml standard library\"\nmaintainer: \"martin@mjambon.com\"\nauthors: \"Martin Jambon\"\nhomepage: \"http://mjambon.com/easy-format.html\"\nbug-reports: \"https://github.com/mjambon/easy-format/issues\"\ndepends: [\n \"ocaml\" {>= \"4.02.3\"}\n \"jbuilder\" {build}\n]\nbuild: [\n [\"jbuilder\" \"build\" \"-p\" name \"-j\" jobs]\n [\"jbuilder\" \"runtest\" \"-p\" name] {with-test}\n]\ndev-repo: \"git+https://github.com/mjambon/easy-format.git\"\nurl {\n src: \"https://github.com/mjambon/easy-format/archive/v1.3.1.tar.gz\"\n checksum: \"md5=4e163700fb88fdcd6b8976c3a216c8ea\"\n}",
"override": null
}
},
"dependencies": [
"@esy-ocaml/substs@0.0.1", "@opam/jbuilder@opam:transition",
"ocaml@4.6.7"
]
},
"@opam/dune@opam:1.4.0": {
"record": {
"name": "@opam/dune",
"version": "opam:1.4.0",
"source":
"archive:https://github.com/ocaml/dune/releases/download/1.4.0/dune-1.4.0.tbz#md5:dc862e5d821ff4d8bef16a78bd472431",
"files": [],
"opam": {
"name": "dune",
"version": "1.4.0",
"opam":
"opam-version: \"2.0\"\nname: \"dune\"\nversion: \"1.4.0\"\nsynopsis: \"Fast, portable and opinionated build system\"\ndescription: \"\"\"\ndune is a build system that was designed to simplify the release of\nJane Street packages. It reads metadata from \"dune\" files following a\nvery simple s-expression syntax.\n\ndune is fast, it has very low-overhead and support parallel builds on\nall platforms. It has no system dependencies, all you need to build\ndune and packages using dune is OCaml. You don't need or make or bash\nas long as the packages themselves don't use bash explicitly.\n\ndune supports multi-package development by simply dropping multiple\nrepositories into the same directory.\n\nIt also supports multi-context builds, such as building against\nseveral opam roots/switches simultaneously. This helps maintaining\npackages across several versions of OCaml and gives cross-compilation\nfor free.\"\"\"\nmaintainer: \"opensource@janestreet.com\"\nauthors: \"Jane Street Group, LLC <opensource@janestreet.com>\"\nlicense: \"MIT\"\nhomepage: \"https://github.com/ocaml/dune\"\nbug-reports: \"https://github.com/ocaml/dune/issues\"\ndepends: [\n \"ocaml\" {>= \"4.02\"}\n]\nconflicts: [\n \"jbuilder\" {!= \"transition\"}\n]\nbuild: [\n [\"ocaml\" \"configure.ml\" \"--libdir\" lib] {opam-version < \"2\"}\n [\"ocaml\" \"bootstrap.ml\"]\n [\"./boot.exe\" \"--release\" \"--subst\"] {pinned}\n [\"./boot.exe\" \"--release\" \"-j\" jobs]\n]\ndev-repo: \"git+https://github.com/ocaml/dune.git\"\nurl {\n src: \"https://github.com/ocaml/dune/releases/download/1.4.0/dune-1.4.0.tbz\"\n checksum: \"md5=dc862e5d821ff4d8bef16a78bd472431\"\n}",
"override": {
"build": [
[ "ocaml", "bootstrap.ml" ],
[ "./boot.exe", "--release", "-j", "4" ]
]
}
}
},
"dependencies": [ "@esy-ocaml/substs@0.0.1", "ocaml@4.6.7" ]
},
"@opam/cppo@opam:1.6.5": {
"record": {
"name": "@opam/cppo",
"version": "opam:1.6.5",
"source":
"archive:https://github.com/mjambon/cppo/archive/v1.6.5.tar.gz#md5:1cd25741d31417995b0973fe0b6f6c82",
"files": [],
"opam": {
"name": "cppo",
"version": "1.6.5",
"opam":
"opam-version: \"2.0\"\nname: \"cppo\"\nversion: \"1.6.5\"\nsynopsis: \"Equivalent of the C preprocessor for OCaml programs\"\nmaintainer: \"martin@mjambon.com\"\nauthors: \"Martin Jambon\"\nlicense: \"BSD-3-Clause\"\nhomepage: \"https://github.com/mjambon/cppo\"\nbug-reports: \"https://github.com/mjambon/cppo/issues\"\ndepends: [\n \"ocaml\"\n \"jbuilder\" {build & >= \"1.0+beta17\"}\n \"base-unix\"\n]\nbuild: [\n [\"jbuilder\" \"subst\" \"-p\" name] {pinned}\n [\"jbuilder\" \"build\" \"-p\" name \"-j\" jobs]\n [\"jbuilder\" \"runtest\" \"-p\" name] {with-test}\n]\ndev-repo: \"git+https://github.com/mjambon/cppo.git\"\nurl {\n src: \"https://github.com/mjambon/cppo/archive/v1.6.5.tar.gz\"\n checksum: \"md5=1cd25741d31417995b0973fe0b6f6c82\"\n}",
"override": null
}
},
"dependencies": [
"@esy-ocaml/substs@0.0.1", "@opam/base-unix@opam:base",
"@opam/jbuilder@opam:transition", "ocaml@4.6.7"
]
},
"@opam/conf-which@opam:1": {
"record": {
"name": "@opam/conf-which",
"version": "opam:1",
"source": "no-source:",
"files": [],
"opam": {
"name": "conf-which",
"version": "1",
"opam":
"opam-version: \"2.0\"\nname: \"conf-which\"\nversion: \"1\"\nsynopsis: \"Virtual package relying on which\"\ndescription:\n \"This package can only install if the which program is installed on the system.\"\nmaintainer: \"unixjunkie@sdf.org\"\nauthors: \"Carlo Wood\"\nlicense: \"GPL-2+\"\nhomepage: \"http://www.gnu.org/software/which/\"\nbug-reports: \"https://github.com/ocaml/opam-repository/issues\"\nbuild: [\"which\" \"which\"]\ndepexts: [\n [\"which\"] {os-distribution = \"centos\"}\n [\"which\"] {os-distribution = \"fedora\"}\n [\"which\"] {os-distribution = \"opensuse\"}\n [\"debianutils\"] {os-distribution = \"debian\"}\n [\"debianutils\"] {os-distribution = \"ubuntu\"}\n [\"which\"] {os-distribution = \"nixos\"}\n [\"which\"] {os-distribution = \"archlinux\"}\n]",
"override": null
}
},
"dependencies": [ "@esy-ocaml/substs@0.0.1" ]
},
"@opam/conf-m4@opam:1": {
"record": {
"name": "@opam/conf-m4",
"version": "opam:1",
"source": "no-source:",
"files": [],
"opam": {
"name": "conf-m4",
"version": "1",
"opam":
"opam-version: \"2.0\"\nname: \"conf-m4\"\nversion: \"1\"\nsynopsis: \"Virtual package relying on m4\"\ndescription:\n \"This package can only install if the m4 binary is installed on the system.\"\nmaintainer: \"tim@gfxmonk.net\"\nauthors: \"GNU Project\"\nlicense: \"GPL-3\"\nhomepage: \"http://www.gnu.org/software/m4/m4.html\"\nbug-reports: \"https://github.com/ocaml/opam-repository/issues\"\nbuild: [\"sh\" \"-exc\" \"echo | m4\"]\ndepexts: [\n [\"m4\"] {os-distribution = \"debian\"}\n [\"m4\"] {os-distribution = \"ubuntu\"}\n [\"m4\"] {os-distribution = \"fedora\"}\n [\"m4\"] {os-distribution = \"rhel\"}\n [\"m4\"] {os-distribution = \"centos\"}\n [\"m4\"] {os-distribution = \"alpine\"}\n [\"m4\"] {os-distribution = \"nixos\"}\n [\"m4\"] {os-distribution = \"opensuse\"}\n [\"m4\"] {os-distribution = \"oraclelinux\"}\n [\"m4\"] {os-distribution = \"archlinux\"}\n]",
"override": null
}
},
"dependencies": [ "@esy-ocaml/substs@0.0.1" ]
},
"@opam/camomile@opam:1.0.1": {
"record": {
"name": "@opam/camomile",
"version": "opam:1.0.1",
"source":
"archive:https://github.com/yoriyuki/Camomile/releases/download/1.0.1/camomile-1.0.1.tbz#md5:82e016653431353a07f22c259adc6e05",
"files": [],
"opam": {
"name": "camomile",
"version": "1.0.1",
"opam":
"opam-version: \"2.0\"\nname: \"camomile\"\nversion: \"1.0.1\"\nsynopsis: \"A Unicode library\"\ndescription: \"\"\"\nCamomile is a Unicode library for OCaml. Camomile provides Unicode character\ntype, UTF-8, UTF-16, UTF-32 strings, conversion to/from about 200 encodings,\ncollation and locale-sensitive case mappings, and more. The library is currently\ndesigned for Unicode Standard 3.2.\"\"\"\nmaintainer: \"yoriyuki.y@gmail.com\"\nauthors: \"Yoriyuki Yamagata\"\nlicense: \"LGPL-2+ with OCaml linking exception\"\nhomepage: \"https://github.com/yoriyuki/Camomile/wiki\"\nbug-reports: \"https://github.com/yoriyuki/Camomile/issues\"\ndepends: [\n \"ocaml\" {>= \"4.02.3\"}\n \"jbuilder\" {build & >= \"1.0+beta17\"}\n]\nbuild: [\n [\"ocaml\" \"configure.ml\" \"--share\" \"%{share}%/camomile\"]\n [\"jbuilder\" \"subst\" \"-p\" name] {pinned}\n [\"jbuilder\" \"build\" \"-p\" name \"-j\" jobs]\n]\ndev-repo: \"git+https://github.com/yoriyuki/Camomile.git\"\nurl {\n src:\n \"https://github.com/yoriyuki/Camomile/releases/download/1.0.1/camomile-1.0.1.tbz\"\n checksum: \"md5=82e016653431353a07f22c259adc6e05\"\n}",
"override": null
}
},
"dependencies": [
"@esy-ocaml/substs@0.0.1", "@opam/jbuilder@opam:transition",
"ocaml@4.6.7"
]
},
"@opam/biniou@opam:1.2.0": {
"record": {
"name": "@opam/biniou",
"version": "opam:1.2.0",
"source":
"archive:https://github.com/mjambon/biniou/archive/v1.2.0.tar.gz#md5:f3e92358e832ed94eaf23ce622ccc2f9",
"files": [],
"opam": {
"name": "biniou",
"version": "1.2.0",
"opam":
"opam-version: \"2.0\"\nname: \"biniou\"\nversion: \"1.2.0\"\nsynopsis:\n \"Binary data format designed for speed, safety, ease of use and backward compatibility as protocols evolve\"\nmaintainer: \"martin@mjambon.com\"\nauthors: \"Martin Jambon\"\nlicense: \"BSD-3-Clause\"\nhomepage: \"https://github.com/mjambon/biniou\"\nbug-reports: \"https://github.com/mjambon/biniou/issues\"\ndepends: [\n \"ocaml\" {>= \"4.02.3\"}\n \"conf-which\" {build}\n \"jbuilder\" {build & >= \"1.0+beta7\"}\n \"easy-format\"\n]\nbuild: [\n [\"jbuilder\" \"build\" \"-p\" name \"-j\" jobs]\n [\"jbuilder\" \"runtest\" \"-p\" name] {with-test}\n]\ndev-repo: \"git+https://github.com/mjambon/biniou.git\"\nurl {\n src: \"https://github.com/mjambon/biniou/archive/v1.2.0.tar.gz\"\n checksum: \"md5=f3e92358e832ed94eaf23ce622ccc2f9\"\n}",
"override": null
}
},
"dependencies": [
"@esy-ocaml/substs@0.0.1", "@opam/conf-which@opam:1",
"@opam/easy-format@opam:1.3.1", "@opam/jbuilder@opam:transition",
"ocaml@4.6.7"
]
},
"@opam/base-unix@opam:base": {
"record": {
"name": "@opam/base-unix",
"version": "opam:base",
"source": "no-source:",
"files": [],
"opam": {
"name": "base-unix",
"version": "base",
"opam":
"opam-version: \"2.0\"\nname: \"base-unix\"\nversion: \"base\"\nsynopsis: \"\"\ndescription: \"Unix library distributed with the OCaml compiler\"\nmaintainer: \"https://github.com/ocaml/opam-repository/issues\"",
"override": null
}
},
"dependencies": [ "@esy-ocaml/substs@0.0.1" ]
},
"@opam/base-threads@opam:base": {
"record": {
"name": "@opam/base-threads",
"version": "opam:base",
"source": "no-source:",
"files": [],
"opam": {
"name": "base-threads",
"version": "base",
"opam":
"opam-version: \"2.0\"\nname: \"base-threads\"\nversion: \"base\"\nsynopsis: \"\"\ndescription: \"Threads library distributed with the OCaml compiler\"\nmaintainer: \"https://github.com/ocaml/opam-repository/issues\"",
"override": null
}
},
"dependencies": [ "@esy-ocaml/substs@0.0.1" ]
},
"@opam/base-bytes@opam:base": {
"record": {
"name": "@opam/base-bytes",
"version": "opam:base",
"source": "no-source:",
"files": [],
"opam": {
"name": "base-bytes",
"version": "base",
"opam":
"opam-version: \"2.0\"\nname: \"base-bytes\"\nversion: \"base\"\nsynopsis: \"Bytes library distributed with the OCaml compiler\"\nmaintainer: \" \"\nauthors: \" \"\nhomepage: \" \"\ndepends: [\n \"ocaml\" {>= \"4.02.0\"}\n \"ocamlfind\" {>= \"1.5.3\"}\n]",
"override": null
}
},
"dependencies": [
"@esy-ocaml/substs@0.0.1", "@opam/ocamlfind@opam:1.8.0",
"ocaml@4.6.7"
]
},
"@esy-ocaml/substs@0.0.1": {
"record": {
"name": "@esy-ocaml/substs",
"version": "0.0.1",
"source":
"archive:https://registry.npmjs.org/@esy-ocaml/substs/-/substs-0.0.1.tgz#sha1:59ebdbbaedcda123fc7ed8fb2b302b7d819e9a46",
"files": [],
"opam": null
},
"dependencies": []
}
}
}
================================================
FILE: flake.nix
================================================
{
description = "Nix Flake for ReasonML";
inputs.nixpkgs.url = "github:nix-ocaml/nix-overlays";
outputs =
{ self, nixpkgs }:
let
forAllSystems =
f:
nixpkgs.lib.genAttrs nixpkgs.lib.systems.flakeExposed (
system:
let
pkgs = nixpkgs.legacyPackages.${system}.extend (
self: super: {
ocamlPackages = super.ocaml-ng.ocamlPackages_5_4;
}
);
in
f pkgs
);
in
{
packages = forAllSystems (
pkgs:
let
packages = pkgs.callPackage ./nix { };
in
{
inherit packages;
default = packages.reason;
}
);
devShells = forAllSystems (pkgs: {
default = pkgs.callPackage ./nix/shell.nix {
reason = self.packages.${pkgs.stdenv.hostPlatform.system}.default;
};
release = pkgs.callPackage ./nix/shell.nix {
reason = self.packages.${pkgs.stdenv.hostPlatform.system}.default;
release-mode = true;
};
});
};
}
================================================
FILE: js/dune
================================================
(executable
(name refmt)
(modes js)
(js_of_ocaml
(flags
--source-map
--debug-info
--pretty
--linkall
+weak.js
+toplevel.js
--opt
3
--disable
strict))
(flags :standard -open StdLabels)
(libraries reason js_of_ocaml))
================================================
FILE: js/refmt.ml
================================================
(*
* Note: This file is currently broken, since Reason removed
* Reason_syntax_util.Error in favor of Reerror's `Printexc.to_string e`
*)
open Js_of_ocaml
module RE = Reason.Reason_toolchain.RE
module ML = Reason.Reason_toolchain.ML
let locationToJsObj (loc : Location.t) =
let _file, start_line, start_char = Location.get_pos_info loc.loc_start in
let _, end_line, end_char = Location.get_pos_info loc.loc_end in
(* The right way of handling ocaml syntax error locations. Do do this at home
copied over from
https://github.com/BuckleScript/bucklescript/blob/2ad2310f18567aa13030cdf32adb007d297ee717/jscomp/super_errors/super_location.ml#L73
*)
let normalizedRange =
if start_char == -1 || end_char == -1
then
(* happens sometimes. Syntax error for example *)
None
else if start_line = end_line && start_char >= end_char
then
(* in some errors, starting char and ending char can be the same. But
since ending char was supposed to be exclusive, here it might end up
smaller than the starting char if we naively did start_char + 1 to just
the starting char and forget ending char *)
let same_char = start_char + 1 in
Some ((start_line, same_char), (end_line, same_char))
else
(* again: end_char is exclusive, so +1-1=0 *)
Some ((start_line, start_char + 1), (end_line, end_char))
in
match normalizedRange with
| None -> Js.undefined
| Some ((start_line, start_line_start_char), (end_line, end_line_end_char)) ->
let intToJsFloatToAny i =
i |> float_of_int |> Js.number_of_float |> Js.Unsafe.inject
in
Js.def
(Js.Unsafe.obj
[| "startLine", intToJsFloatToAny start_line
; "startLineStartChar", intToJsFloatToAny start_line_start_char
; "endLine", intToJsFloatToAny end_line
; "endLineEndChar", intToJsFloatToAny end_line_end_char
|])
let parseWith f code =
(* you can't throw an Error here. jsoo parses the string and turns it into
something else *)
let throwAnything = Js.Unsafe.js_expr "function(a) {throw a}" in
try code |> Js.to_string |> Lexing.from_string |> f with
(* from ocaml and reason *)
| Syntaxerr.Error err as exn ->
let loc = Syntaxerr.location_of_error err in
let jsLocation = locationToJsObj loc in
let error_buf = Buffer.create 256 in
let error_fmt = Format.formatter_of_buffer error_buf in
(match Location.error_of_exn exn with
| Some (`Ok err) ->
Format.fprintf error_fmt "@[%a@]@." Location.print_report err
| _ -> assert false);
let errorString = Format.flush_str_formatter () in
let jsError =
Js.Unsafe.obj
[| "message", Js.Unsafe.inject (Js.string errorString)
; "location", Js.Unsafe.inject jsLocation
|]
in
Js.Unsafe.fun_call throwAnything [| Js.Unsafe.inject jsError |]
let parseRE = parseWith RE.implementation_with_comments
let parseREI = parseWith RE.interface_with_comments
let parseML = parseWith ML.implementation_with_comments
let parseMLI = parseWith ML.interface_with_comments
let printWith f structureAndComments =
f Format.str_formatter structureAndComments;
Format.flush_str_formatter () |> Js.string
let printRE = printWith RE.print_implementation_with_comments
let printREI = printWith RE.print_interface_with_comments
let printML = printWith ML.print_implementation_with_comments
let printMLI = printWith ML.print_interface_with_comments
let _ = Js.export "parseRE" parseRE
let _ = Js.export "parseREI" parseREI
let _ = Js.export "parseML" parseML
let _ = Js.export "parseMLI" parseMLI
let _ = Js.export "printRE" printRE
let _ = Js.export "printREI" printREI
let _ = Js.export "printML" printML
let _ = Js.export "printMLI" printMLI
================================================
FILE: js/testRefmtJs.js
================================================
const refmt = require('../refmt')
console.log(refmt)
console.log(refmt.printRE(refmt.parseRE(`let f = (a) => a + 1; print_int(f(5))`)))
console.log(refmt.printREI(refmt.parseREI(`let f: (~a: string) => int`)))
console.log(refmt.printML(refmt.parseML(`let f a = a + 1 print_int @@ f 5`)))
console.log(refmt.printMLI(refmt.parseMLI(`val f : a:string -> int`)))
try {
refmt.parseRE(`let f => =`)
} catch (e) {
console.log(e)
}
try {
refmt.parseMLI(`val f: `)
} catch (e) {
console.log(e)
}
try {
refmt.parseRE(`type X = Foo`)
} catch (e) {
console.log(e)
}
console.log("=============== we're good! ===============")
================================================
FILE: nix/ci.nix
================================================
{ ocamlVersion }:
let
lock = builtins.fromJSON (builtins.readFile ./../flake.lock);
pkgs =
let
src = fetchGit {
url = with lock.nodes.nixpkgs.locked; "https://github.com/${owner}/${repo}";
inherit (lock.nodes.nixpkgs.locked) rev;
allRefs = true;
};
in
import src { };
in
pkgs.callPackage ./. { doCheck = true; }
================================================
FILE: nix/default.nix
================================================
{
lib,
ocamlPackages,
doCheck ? false,
}:
rec {
reason = ocamlPackages.buildDunePackage {
pname = "reason";
version = "0.0.1-dev";
src =
let
fs = lib.fileset;
in
fs.toSource {
root = ./..;
fileset = fs.unions [
../dune-project
../dune
../reason.opam
../scripts
../src
../test
];
};
inherit doCheck;
nativeBuildInputs = with ocamlPackages; [
cppo
menhir
];
propagatedBuildInputs = with ocamlPackages; [
cmdliner
merlin-extend
menhirSdk
menhirLib
fix
ppxlib_gt_0_37
dune-build-info
];
};
rtop = ocamlPackages.buildDunePackage {
pname = "rtop";
version = "0.0.1-dev";
src =
let
fs = lib.fileset;
in
fs.toSource {
root = ./..;
fileset = fs.unions [
../dune-project
../dune
../rtop.opam
../scripts
../rtop
../test
];
};
inherit doCheck;
nativeBuildInputs = with ocamlPackages; [ cppo ];
propagatedBuildInputs = [
reason
ocamlPackages.utop
];
};
}
================================================
FILE: nix/shell.nix
================================================
{
mkShell,
ocamlPackages,
reason,
cacert,
curl,
git,
release-mode ? false,
}:
mkShell {
inputsFrom = [ reason ];
nativeBuildInputs = with ocamlPackages; [
utop
merlin
# odoc
ocamlformat
];
buildInputs =
with ocamlPackages;
(
if release-mode then
[
cacert
curl
dune-release
git
]
else
[ ]
);
}
================================================
FILE: package.json
================================================
{
"name": "reason",
"version": "3.6.2",
"description": "Simple, fast & type safe code that leverages the JavaScript & OCaml ecosystems",
"repository": {
"type": "git",
"url": "https://github.com/reasonml/reason.git"
},
"main": "refmt.js",
"keywords": [
"reason",
"ocaml",
"react",
"javascript"
],
"license": "MIT",
"homepage": "https://github.com/reasonml/reason"
}
================================================
FILE: reason.json
================================================
{
"name": "@esy-ocaml/reason",
"version": "3.8.2",
"license": "MIT",
"description": "Native Compiler Support for Reason: Simple, fast & type safe code that leverages the JavaScript & OCaml ecosystems",
"repository": {
"type": "git",
"url": "https://github.com/reasonml/reason.git"
},
"dependencies": {
"ocaml": ">= 4.2.0 < 5.1.0",
"@opam/fix": "*",
"@opam/ocamlfind": "*",
"@opam/menhir": " >= 20180523.0.0",
"@opam/merlin-extend": " >= 0.6",
"@opam/ppxlib": "> 0.28.x",
"@opam/dune": ">= 2.9.3",
"@opam/dune-build-info": ">= 2.9.3"
},
"devDependencies": {
"@opam/merlin": "*",
"ocaml": "~4.14.0"
},
"esy": {
"build": [
[
"dune",
"build",
"-p",
"reason",
"--disable-promotion"
]
]
}
}
================================================
FILE: reason.opam
================================================
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
version: "3.17.3"
synopsis: "Reason: Syntax & Toolchain for OCaml"
description: """
Reason gives OCaml a new syntax that is remniscient of languages like
JavaScript. It's also the umbrella project for a set of tools for the OCaml &
JavaScript ecosystem."""
maintainer: [
"Jordan Walke <jordojw@gmail.com>"
"Antonio Nuno Monteiro <anmonteiro@gmail.com>"
]
authors: ["Jordan Walke <jordojw@gmail.com>"]
license: "MIT"
homepage: "https://reasonml.github.io/"
bug-reports: "https://github.com/reasonml/reason/issues"
depends: [
"dune" {>= "3.18"}
"ocaml" {>= "4.08" & < "5.6"}
"ocamlfind" {build}
"cmdliner" {>= "1.1.0"}
"dune-build-info" {>= "2.9.3"}
"menhir" {>= "20180523"}
"merlin-extend" {>= "0.6.2"}
"fix"
"cppo"
"ppxlib" {>= "0.36"}
"odoc" {with-doc}
]
build: [
["dune" "subst"] {dev}
[
"dune"
"build"
"-p"
name
"-j"
jobs
"@install"
"@runtest" {with-test}
"@doc" {with-doc}
]
]
dev-repo: "git+https://github.com/reasonml/reason.git"
x-maintenance-intent: ["(latest)"]
pin-depends: [
[ "ppxlib.dev" "https://github.com/NathanReb/ppxlib/archive/547c6cfd69671e147767e0937d069c5b9eb2aa4a.tar.gz" ]
]
================================================
FILE: reason.opam.template
================================================
pin-depends: [
[ "ppxlib.dev" "https://github.com/NathanReb/ppxlib/archive/547c6cfd69671e147767e0937d069c5b9eb2aa4a.tar.gz" ]
]
================================================
FILE: rtop/dune
================================================
(library
(name rtoplib)
(public_name rtop)
(modules reason_util reason_utop reason_toploop)
(modes byte)
(flags :standard -open StdLabels)
(libraries
menhirLib
reason.easy_format
reason
utop
reason.ocaml-migrate-parsetree))
(rule
(targets reason_toploop.ml)
(deps reason_toploop.cppo.ml)
(action
(run cppo -V OCAML:%{ocaml_version} %{deps} -o %{targets})))
(rule
(targets reason_utop.ml)
(deps reason_utop.cppo.ml)
(action
(run cppo -V OCAML:%{ocaml_version} %{deps} -o %{targets})))
(executable
(name rtop)
(public_name rtop)
(package rtop)
(modules rtop)
(link_flags -linkall)
(modes byte)
(flags :standard -open StdLabels)
(libraries rtop))
================================================
FILE: rtop/reason_toploop.cppo.ml
================================================
(*
* Copyright (c) 2015-present, Facebook, Inc.
*
* This source code is licensed under the MIT license found in the
* LICENSE file in the root directory of this source tree.
*)
open Reason
let default_parse_toplevel_phrase = !Toploop.parse_toplevel_phrase
let reason_parse_toplevel_phrase =
Reason_util.correctly_catch_parse_errors
(fun x ->
let r =
Reason_toolchain.To_current.copy_toplevel_phrase
(Reason_toolchain.RE.toplevel_phrase x)
in
#if OCAML_VERSION >= (5,2,0)
(* NOTE(anmonteiro): after https://github.com/ocaml/ocaml/pull/12029, we get a
Fatal error: exception Invalid_argument("index out of bounds")
Raised by primitive operation at Toploop.ends_with_lf in file "toplevel/toploop.ml"
Setting `lex_eof_reached` seems to avoid whatever check upstream is doing. *)
x.lex_eof_reached <- true;
#endif
r)
(* this file's triggered by utop/rtop *)
let main () =
if List.exists ~f:((=) "camlp4o") !Topfind.predicates ||
List.exists ~f:((=) "camlp4r") !Topfind.predicates then
print_endline "Reason is incompatible with camlp4!"
else begin
#if OCAML_VERSION >= (5,3,0)
if not (Toploop.prepare Format.err_formatter ()) then raise (Compenv.Exit_with_status 2);
#endif
Toploop.parse_toplevel_phrase := (fun t ->
if !Reason_utop.current_top = UTop then
default_parse_toplevel_phrase t
else
reason_parse_toplevel_phrase t);
Toploop.parse_use_file := Reason_util.correctly_catch_parse_errors
(fun x -> List.map ~f:Reason_toolchain.To_current.copy_toplevel_phrase
(Reason_toolchain.RE.use_file x));
(* Toploop.print_out_sig_item := M17n_util.utf8_print_out_sig_item !Toploop.print_out_sig_item; *)
(* Toploop.install_printer Predef.path_string Predef.type_string *)
(* (fun fmt obj -> M17n_util.utf8_print_string fmt (Obj.magic obj)); *)
end
================================================
FILE: rtop/reason_util.ml
================================================
(**
* Some of this was coppied from @whitequark's m17n project.
*)
(*
* Portions Copyright (c) 2015-present, Facebook, Inc.
*
* This source code is licensed under the MIT license found in the
* LICENSE file in the root directory of this source tree.
*)
let transmogrify_exn exn template =
assert (Obj.tag (Obj.repr exn) = 0);
Obj.set_field (Obj.repr exn) 0 (Obj.field (Obj.repr template) 0);
exn
let extract_exn src name =
try
ignore (!Toploop.parse_toplevel_phrase (Lexing.from_string src));
assert false
with
| exn ->
assert (Printexc.exn_slot_name exn = name);
exn
let exn_Lexer_Error = extract_exn "\128" "Lexer.Error"
let exn_Syntaxerr_Error = extract_exn "fun" "Syntaxerr.Error"
let correctly_catch_parse_errors fn lexbuf =
(*let kind = if !Toploop.input_name = "//toplevel//" then `Toplevel else
`Batch in*)
fn lexbuf
(*with exn when kind = `Toplevel -> (* In expunged toplevel, we have a
split-brain situation where toplevel and m17n have different internal IDs for
the "same" exceptions. Fixup. *) raise (match exn with (* FIXME... Maybe? *)
(*| Reason_lexer.Error _ -> transmogrify_exn exn exn_Lexer_Error*) |
Syntaxerr.Error _ -> transmogrify_exn exn exn_Syntaxerr_Error |
Reason_syntax_util.Error (loc, _) -> transmogrify_exn
(Syntaxerr.Error(Syntaxerr.Other loc)) exn_Syntaxerr_Error | _ -> exn) *)
================================================
FILE: rtop/reason_utop.cppo.ml
================================================
(** * Some of this was coppied from \@whitequark's m17n project. *)
(*
* Portions Copyright (c) 2015-present, Facebook, Inc.
*
* This source code is licensed under the MIT license found in the
* LICENSE file in the root directory of this source tree.
*)
open Reason
module ToploopBackup = struct
let print_out_value = !Toploop.print_out_value
let print_out_type = !Toploop.print_out_type
let print_out_class_type = !Toploop.print_out_class_type
let print_out_module_type = !Toploop.print_out_module_type
let print_out_type_extension = !Toploop.print_out_type_extension
let print_out_sig_item = !Toploop.print_out_sig_item
let print_out_signature = !Toploop.print_out_signature
let print_out_phrase = !Toploop.print_out_phrase
let[@ocaml.warning "-3"] current_show =
Hashtbl.find Toploop.directive_table "show"
end
#if OCAML_VERSION >= (5,4,0)
let rec lident_operator_map mapper li =
let open Longident in
match li with
| Lident s -> Lident (mapper s)
| Ldot (x, s) -> Ldot (x, { loc = s.loc; txt = mapper s.txt})
| Lapply (x, y) ->
Lapply
( { loc = x.loc; txt = lident_operator_map mapper x.txt }
, { loc = y.loc; txt = lident_operator_map mapper y.txt })
#else
let rec lident_operator_map mapper li =
let open Longident in
match li with
| Lident s -> Lident (mapper s)
| Ldot (x, s) -> Ldot (x, mapper s)
| Lapply (x, y) ->
Lapply (lident_operator_map mapper x, lident_operator_map mapper y)
#endif
type top_kind =
| RTop
| UTop
let current_top = ref RTop
let init_reason () =
if List.exists ~f:(( = ) "camlp4o") !Topfind.predicates
|| List.exists ~f:(( = ) "camlp4r") !Topfind.predicates
then print_endline "Reason is incompatible with camlp4!"
else
let use_file x =
List.map
~f:Reason_toolchain.To_current.copy_toplevel_phrase
(Reason_toolchain.RE.use_file x)
in
current_top := RTop;
UTop.set_phrase_terminator ";";
UTop.prompt :=
fst
(React.S.create
LTerm_text.(eval [ B_fg LTerm_style.green; S "Reason # " ]));
UTop.parse_toplevel_phrase :=
UTop.parse_default
(Reason_util.correctly_catch_parse_errors (fun x ->
Reason_toolchain.To_current.copy_toplevel_phrase
(Reason_toolchain.RE.toplevel_phrase x)));
UTop.parse_use_file :=
UTop.parse_default (Reason_util.correctly_catch_parse_errors use_file);
UTop.history_file_name :=
Some (Filename.concat LTerm_resources.home ".rtop-history");
Toploop.parse_use_file := Reason_util.correctly_catch_parse_errors use_file;
(* Printing in Reason syntax *)
let open Reason_toolchain.From_current in
let wrap f g fmt x =
g fmt (f x)
in
#if OCAML_VERSION >= (5,3,0)
let wrap_doc f g fmt x =
wrap f (Format_doc.deprecated g) fmt x
#else
let wrap_doc = wrap
#endif
in
Toploop.print_out_value := wrap copy_out_value Reason_oprint.print_out_value;
Toploop.print_out_type := wrap_doc copy_out_type Reason_oprint.print_out_type;
Toploop.print_out_class_type :=
wrap_doc copy_out_class_type Reason_oprint.print_out_class_type;
Toploop.print_out_module_type :=
wrap_doc copy_out_module_type Reason_oprint.print_out_module_type;
Toploop.print_out_type_extension :=
wrap_doc copy_out_type_extension Reason_oprint.print_out_type_extension;
Toploop.print_out_sig_item :=
wrap_doc copy_out_sig_item Reason_oprint.print_out_sig_item;
Toploop.print_out_signature :=
wrap_doc (List.map ~f:copy_out_sig_item) Reason_oprint.print_out_signature;
Toploop.print_out_phrase :=
wrap copy_out_phrase Reason_oprint.print_out_phrase;
let current_show_fn =
match ToploopBackup.current_show with
| Toploop.Directive_ident fn -> fn
| _ -> assert false
in
Hashtbl.replace
(Toploop.directive_table [@ocaml.warning "-3"])
"show"
(Toploop.Directive_ident
(fun li ->
let li' =
lident_operator_map Reason_syntax_util.reason_to_ml_swap li
in
current_show_fn li'))
let init_ocaml () =
current_top := UTop;
UTop.set_phrase_terminator ";;";
UTop.prompt :=
fst
(React.S.create
LTerm_text.(eval [ B_fg LTerm_style.green; S "OCaml # " ]));
UTop.parse_toplevel_phrase := UTop.parse_toplevel_phrase_default;
UTop.parse_use_file := UTop.parse_use_file_default;
UTop.history_file_name :=
Some (Filename.concat LTerm_resources.home ".utop-history");
Toploop.print_out_value := ToploopBackup.print_out_value;
Toploop.print_out_type := ToploopBackup.print_out_type;
Toploop.print_out_class_type := ToploopBackup.print_out_class_type;
Toploop.print_out_module_type := ToploopBackup.print_out_module_type;
Toploop.print_out_type_extension := ToploopBackup.print_out_type_extension;
Toploop.print_out_sig_item := ToploopBackup.print_out_sig_item;
Toploop.print_out_signature := ToploopBackup.print_out_signature;
Toploop.print_out_phrase := ToploopBackup.print_out_phrase;
Hashtbl.replace
(Toploop.directive_table [@ocaml.warning "-3"])
"show"
ToploopBackup.current_show
let toggle_syntax () =
match !current_top with RTop -> init_ocaml () | UTop -> init_reason ()
let () =
Hashtbl.add
(Toploop.directive_table [@ocaml.warning "-3"])
"toggle_syntax"
(Toploop.Directive_none toggle_syntax);
init_reason ()
================================================
FILE: rtop/rtop.ml
================================================
let print_init_message () =
print_string
"\n\
\ ___ _______ ________ _ __\n\
\ / _ \\/ __/ _ | / __/ __ \\/ |/ /\n\
\ / , _/ _// __ |_\\ \\/ /_/ / /\n\
\ /_/|_/___/_/ |_/___/\\____/_/|_/\n\n\
\ Execute statements/let bindings. Hit <enter> after the semicolon. \
Ctrl-d to quit.\n\n\
\ > let myVar = \"Hello Reason!\";\n\
\ > let myList: list(string) = [\"first\", \"second\"];\n\
\ > #use \"./src/myFile.re\"; /* loads the file into here */\n"
let start_utop () =
(match !Clflags.init_file with
| Some _ -> ()
| None ->
let xdg_fn =
LTerm_resources.xdgbd_file ~loc:LTerm_resources.Config "rtop/init.re"
in
(* NOTE(anmonteiro): in the future, we could try checking for `~/.ocamlinit`
and `~/.config/utop/init.ml` and convert those to Reason *)
Clflags.init_file :=
(match Sys.file_exists xdg_fn with
| true -> Some xdg_fn
| false ->
(* If `~/.config/rtop/init.re` isn't found, we can't be loading a
user's `init.ml` because it'll be full of syntax errors for `rtop`.
Create an empty temp file instead. *)
Some (Filename.temp_file "rtop" ".re")));
UTop_main.main ()
let main () =
UTop.require [ "reason.ocaml-migrate-parsetree"; "menhirLib" ];
(try Topdirs.dir_directory (Sys.getenv "OCAML_TOPLEVEL_PATH") with
| Not_found -> ());
UTop.require [ "reason.easy_format"; "reason" ];
Rtoplib.Reason_toploop.main ();
Rtoplib.Reason_utop.init_reason ();
print_init_message ();
start_utop ()
let () = main ()
================================================
FILE: rtop.json
================================================
{
"name": "@esy-ocaml/rtop",
"version": "3.8.2",
"license": "MIT",
"repository": {
"type": "git",
"url": "https://github.com/reasonml/reason.git"
},
"dependencies": {
"@esy-ocaml/substs": "^0.0.1",
"@opam/ocamlfind": "*",
"@opam/dune": ">= 2.9.3",
"@opam/reason": "^3.8.0",
"@opam/utop": " >= 1.17.0",
"ocaml": ">= 4.3.0 < 5.2.0"
},
"devDependencies": {
"@opam/merlin": "*",
"ocaml": "5.x"
},
"esy": {
"build": [["dune", "build", "-p", "reason", "--disable-promotion"]]
}
}
================================================
FILE: rtop.opam
================================================
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
version: "3.17.3"
synopsis: "Reason toplevel"
description:
"rtop is the toplevel (or REPL) for Reason, based on utop (https://github.com/ocaml-community/utop)."
maintainer: [
"Jordan Walke <jordojw@gmail.com>"
"Antonio Nuno Monteiro <anmonteiro@gmail.com>"
]
authors: ["Jordan Walke <jordojw@gmail.com>"]
license: "MIT"
homepage: "https://reasonml.github.io/"
bug-reports: "https://github.com/reasonml/reason/issues"
depends: [
"dune" {>= "3.18"}
"ocaml" {>= "4.08" & < "5.6"}
"reason" {= version}
"utop" {>= "2.0"}
"cppo"
"odoc" {with-doc}
]
build: [
["dune" "subst"] {dev}
[
"dune"
"build"
"-p"
name
"-j"
jobs
"@install"
"@runtest" {with-test}
"@doc" {with-doc}
]
]
dev-repo: "git+https://github.com/reasonml/reason.git"
x-maintenance-intent: ["(latest)"]
================================================
FILE: scripts/esy-prepublish.js
================================================
/**
* Copyright 2004-present Facebook. All Rights Reserved.
*
* This source code is licensed under the MIT license found in the
* LICENSE file in the root directory of this source tree.
*/
//this file was copied from https://github.com/facebook/reason/blob/master/scripts/esy-prepublish.js
//
// Usage: Run from the repo root:
//
// node scripts/esy-prepublish.js relative/path/to/some-package-name.json
// The script will copy relative/path/to/some-package-name.json into
// ./package.json and delete any remaining esy.json at the root. It will also
// search for relative/path/to/some-package-name.README.md (or if that is not
// found, then relative/path/to/README.md) and copy it to ./README.md at the
// repo root so that the published package has its appropriate README on the
// npm page.
const fs = require('fs');
const cp = require('child_process');
const path = require('path');
const quote = s => '"' + s + '"';
const opamifyName = name => {
if(name.indexOf("@opam/") === 0) {
return '"' + name.substr(6) + '"';
} else if(name === '@esy-ocaml/reason') {
return '"reason"';
} else {
if(name.indexOf('@') === 0) {
var scopeAndPackage = name.substr(1).split('/');
// return 'npm--' + scopeAndPackage[0] + '--' + scopeAndPackage[1];
// Assumes the packages have name.opam files, without the scope.
return '"' + scopeAndPackage[1] + '"';
} else {
return '"' + name + '"';
}
}
};
const opamifyVersion = v => {
var v = v.trim();
if(v.charAt(0) === '^') {
var postCaret = v.substr(1);
var nextDotIndex = postCaret.indexOf('.');
if(nextDotIndex !== -1) {
var major = postCaret.substr(0, nextDotIndex);
var rest = postCaret.substr(nextDotIndex + 1);
return '>= "' + postCaret + '" & < "' + (parseInt(major) + 1) + '.0.0"';
} else {
var major = postCaret.substr(0, nextDotIndex);
return '>= "' + postCaret + '" & < "' + (parseInt(postCaret) + 1) + '"';
}
} else {
return v.replace(/\s+<\s+/g, s => '" & < "')
.replace(/\s+<=\s*/g, s => '" & <= "')
.replace(/^<\s+/g, s => '< "')
.replace(/^<=\s*/g, s => '<= "')
.replace(/\s+>\s+/g, s => '" & > "')
.replace(/\s+>=/g, s => '" & >= "')
.replace(/^>\s+/g, s => '> "')
.replace(/^>=\s*/g, s => '>= "')
+ '"';
}
};
const depMap = (o) => {
return Object.entries(o).map(([name, vers]) =>
opamifyName(name) +
(vers === '*' ? '' : ' {' + opamifyVersion(vers) + '}')
)
};
const createOpamText = package => {
const opamTemplate = [
'opam-version: ' + quote("2.0"),
'maintainer: ' + quote(package.author),
'authors: [' + quote(package.author) + ']',
'license: ' + quote(package.license),
'homepage: ' + quote(package.homepage),
'doc: ' + quote(package.homepage),
package.repository && package.repository.url ?
('bug-reports: ' + quote(package.repository.url)) :
'',
package.repository && package.repository.url ?
('dev-repo: ' + quote(package.repository.url.replace('https', 'git').replace('http', 'git'))) :
'',
'tags: [' + (package.keywords ? package.keywords.map(quote).join(' ') : '') + ']',
'build: [ [' + package.esy.build.split(' ').map(quote).join(' ') + ' ] ]',
'depends: [',
].concat(depMap(package.dependencies).map(s=>' ' + s)).concat([
']',
'synopsis: ' +
quote(package.description.charAt(0).toUpperCase() + package.description.substr(1)),
'description: ' + quote(package.description)
]);
return opamTemplate.join('\n') + '\n';
};
if (process.cwd() !== path.resolve(__dirname, '..')) {
console.log("ERROR: Must run `make esy-prepublish` from project root.");
process.exit(1);
}
let projectRoot = process.cwd();
let relativeJsonPaths = [];
for (var i = 2; i < process.argv.length; i++) {
let jsonRelativePath = process.argv[i];
relativeJsonPaths.push(jsonRelativePath);
}
if (relativeJsonPaths.length === 0) {
relativeJsonPaths = ['esy.json'];
}
for (var i = 0; i < relativeJsonPaths.length; i++) {
let jsonRelativePath = relativeJsonPaths[i];
let subpackageJson = path.resolve(projectRoot, jsonRelativePath);
if (path.extname(jsonRelativePath) !== '.json') {
console.log(
'You specified an relative path to something that isn\'t a json file (' +
subpackageJson +
'). Specify location of json files relative to repo root.'
);
process.exit(1);
}
if (!jsonRelativePath || !fs.existsSync(subpackageJson)) {
console.log(
'You specified an invalid release package root (' +
subpackageJson +
'). Specify location of packages to release relative to repo root directory.'
);
process.exit(1);
}
}
const head =
cp.spawnSync('git', ['rev-parse', '--verify', 'HEAD']).stdout.toString();
const master =
cp.spawnSync('git', ['rev-parse', '--verify', 'master']).stdout.toString();
// Since we generate opam files, don't check for uncommitted.
// let uncommitted =
// cp.spawnSync('git', ['diff-index', 'HEAD', '--']).stdout.toString();
// if (uncommitted !== "") {
// console.log('ERROR: You have uncommitted changes. Please try on a clean master branch');
// process.exit(1);
// }
process.chdir(projectRoot);
let tarResult = cp.spawnSync(
'tar',
[
'--exclude',
'_esy',
'--exclude',
'node_modules',
'--exclude',
'_build',
'--exclude',
'.git',
'-cf',
'template.tar',
'.'
]
);
let tarErr = tarResult.stderr.toString();
// if (tarErr !== '') {
// console.log('ERROR: Could not create template npm pack for prepublish');
// throw new Error('Error:' + tarErr);
// }
try {
let _releaseDir = path.resolve(projectRoot, '_release');
// For each subpackage, we release the entire source code for all packages, but
// with the root package.json swapped out with the esy.json file in the
// subpackage.
for (var i = 0; i < relativeJsonPaths.length; i++) {
process.chdir(projectRoot);
let jsonRelativePath = relativeJsonPaths[i];
let jsonResolvedPath = path.resolve(projectRoot, jsonRelativePath);
const packageJson = require(jsonResolvedPath);
const packageName = packageJson.name;
const packageVersion = packageJson.version;
console.log('');
console.log('Preparing: ' + jsonRelativePath + ' ' + packageName + '@' + packageVersion);
console.log('-----------------------------------------------------------------------------');
let subpackageReleaseDir = path.resolve(_releaseDir, jsonRelativePath);
if (fs.existsSync(subpackageReleaseDir)) {
console.log('YOU NEED TO REMOVE THE ' + subpackageReleaseDir + ' DIR FIRST!');
process.exit(1);
}
if (!fs.existsSync(_releaseDir)) {
fs.mkdirSync(_releaseDir);
}
fs.mkdirSync(subpackageReleaseDir);
let subpackageReleasePrepDir = path.resolve(_releaseDir, path.join(jsonRelativePath), '_prep');
fs.mkdirSync(subpackageReleasePrepDir);
fs.copyFileSync(
path.join(projectRoot, 'template.tar'),
path.join(subpackageReleasePrepDir, 'template.tar')
);
process.chdir(subpackageReleasePrepDir);
cp.spawnSync('tar', ['-xvf', 'template.tar']);
fs.unlinkSync(path.join(subpackageReleasePrepDir, 'template.tar'));
let readmePath = path.resolve(subpackageReleasePrepDir, 'README.md');
let readmePkgPath =
path.resolve(
subpackageReleasePrepDir,
path.join('src', path.basename(jsonRelativePath, '.json'), 'README.md')
);
let readmeResolvedPath =
fs.existsSync(readmePkgPath) ? readmePkgPath :
fs.existsSync(readmePath) ? readmePath :
null;
let toCopy = [
{
originPath: path.resolve(subpackageReleasePrepDir, jsonRelativePath),
destPath: path.resolve(subpackageReleasePrepDir, 'package.json')
},
{
originPath: readmeResolvedPath,
destPath: path.resolve(subpackageReleasePrepDir, 'README.md')
}
];
for (var j = 0; j < toCopy.length; j++) {
let originPath = toCopy[j].originPath;
let destPath = toCopy[j].destPath;
if (originPath !== null && fs.existsSync(originPath) && destPath !== originPath) {
fs.renameSync(originPath, destPath);
}
}
// If an esy.json file remains, we need to remove it so that it isn't
// picked up as the default by esy (it gives priority to esy.json over
// package.json). But this has to be done _after_ the `mv` above, in case
// the json file that someone published _was_ the esy.json file.
let esyFile = path.resolve(subpackageReleasePrepDir, 'esy.json');
if (fs.existsSync(esyFile)) {
fs.unlinkSync(esyFile);
}
// Create a npm pack to remove all the stuff in .npmignore. This would
// happen when you publish too, but we'll create a directory ./package that
// has all of it removed so you can also easily test linking against it
// from other projects.
process.chdir(subpackageReleasePrepDir);
// Npm pack is just a convenient way to strip out any unnecessary files.
const packResult = cp.spawnSync(process.platform === 'win32' ? 'npm.cmd' : 'npm', ['pack']);
if (packResult.status !== 0) {
console.log('ERROR: Could not create npm pack for ' + subpackageReleasePrepDir);
throw new Error('Error:' + packResult.stderr.toString());
}
const mvTo = subpackageReleaseDir;
fs.readdirSync(subpackageReleasePrepDir).filter(fn => fn.endsWith('.tgz')).forEach(fn => {
fs.renameSync(fn, path.join(mvTo, fn));
});
process.chdir(mvTo);
const tarResult = cp.spawnSync('tar', ['-xvf', '*.tgz'], { shell: true });
if (tarResult.error) {
console.log('ERROR: Could not untar in ' + mvTo);
throw new Error('Error:' + tarResult.stderr.toString());
}
console.log('Prepared for publishing at: ');
console.log(' ' + subpackageReleaseDir);
if(packageJson['esy-prepublish-generate-opam']) {
try {
const opamText = createOpamText(packageJson);
const opamFileName = path.basename(jsonRelativePath, '.json') + '.opam';
let opamResolvedPath = path.resolve(projectRoot, opamFileName);
fs.writeFileSync(opamResolvedPath, opamText);
console.log("Opam file generated. Commit it. Or don't:");
console.log(' ' + opamResolvedPath);
} catch(e) {
console.log("Could not generate opam file. See error below.");
console.log(
"To disable opam file generation, remove `\"esy-prepublish-generate-opam\": true` from " +
jsonRelativePath
);
console.log(' ' + e.toString());
}
} else {
console.log("To generate opam file, add `\"esy-prepublish-generate-opam\": true` to " + jsonRelativePath);
}
console.log('To publish the package to npm do:');
console.log(' cd ' + path.resolve(subpackageReleaseDir, 'package'));
console.log(' npm publish --access=public');
console.log('');
}
} finally {
fs.unlinkSync(path.join(projectRoot, 'template.tar'));
}
================================================
FILE: src/menhir-error-processor/dune
================================================
(executable
(name menhir_error_processor)
(flags :standard -open StdLabels)
(libraries unix menhirSdk))
================================================
FILE: src/menhir-error-processor/menhir_error_processor.ml
================================================
(* This file is an executable run at build time to generate a file called
_build/default/src/reason-parser/reason_parser_explain_raw.ml
That generated file pattern-matches on the error codes that are related to
e.g. accidentally using a reserved keyword as an identifier. Once we get
those error codes, the file reason_parser_explain.ml is run (at parsing time,
aka when you run refmt) and provides a more helpful message for these
categories of errors, than the default "<syntax error>".
Why can't we just check in reason_parser_explain_raw.ml and avoid this build-
time file generation? Because the error code are dependent on the logic
generated by the Menhir parser, and that logic changes when we modify the
parser. Aka, each time we modify the reason_parser, we need to regenerate the
potentially changed error code *)
open MenhirSdk
module G = Cmly_read.Read (struct
let filename = Sys.argv.(1)
end)
open G
let print fmt = Printf.ksprintf print_endline fmt
(* We want to detect any state where an identifier is admissible. That way, we
can assume that if a keyword is used and rejceted, the user was intending to
put an identifier. *)
let states_transitioning_on pred =
let keep_state lr1 =
(* There are two kind of transitions (leading to SHIFT or REDUCE), detect
those who accept identifiers *)
List.exists
~f:(fun (term, _) -> pred (T term))
(Lr1.reductions lr1 [@alert "-deprecated"])
|| List.exists ~f:(fun (sym, _) -> pred sym) (Lr1.transitions lr1)
in
(* Now we filter the list of all states and keep the interesting ones *)
G.Lr1.fold (fun lr1 acc -> if keep_state lr1 then lr1 :: acc else acc) []
let print_transitions_on name pred =
(* Produce a function that will be linked into the reason parser to recognize
states at runtime. TODO: a more compact encoding could be used, for now we
don't care and just pattern matches on states. *)
print "let transitions_on_%s = function" name;
(match states_transitioning_on pred with
| [] -> prerr_endline ("no states matches " ^ name ^ " predicate")
| states ->
List.iter ~f:(fun lr1 -> print " | %d" (Lr1.to_int lr1)) states;
print " -> true");
print " | _ -> false\n"
let terminal_find name =
match
Terminal.fold
(fun t default -> if Terminal.name t = name then Some t else default)
None
with
| Some term -> term
| None -> failwith ("Unkown terminal " ^ name)
let () =
List.iter
~f:(fun term ->
let symbol = T (terminal_find term) in
let name = (String.lowercase_ascii term [@ocaml.warning "-3"]) in
print_transitions_on name (( = ) symbol))
[ "LIDENT"; "UIDENT"; "SEMI"; "RBRACKET"; "RPAREN"; "RBRACE" ]
================================================
FILE: src/menhir-recover/attributes.ml
================================================
(* Attributes guide the recovery .
Some information can be passed to Menhir-recover via attributes. These are
pieces of string that are ignored by Menhir itself and are transmitted to
Menhir-recover.
The attributes that are relevant to Menhir-recover are always prefixed with
`recover.`. An attribute with the same prefix and that is not understood by
Menhir-recover will produce a warning message (to detect a typo or a
misplaced attribute). *)
(** Specification of attributes that are meaningful for recovery *)
module type ATTRIBUTES = sig
module G : MenhirSdk.Cmly_api.GRAMMAR
(** The Menhir grammar to which these apply *)
(** Recovery cost
When the parser is in an error state, Menhir-recover will invent some
input that recovers from this error. In most grammars, this problem has
many solutions, often an infinity.
But not all solutions are equally nice. Some will have repetitions, some
will generate undesirable AST nodes or trigger error reductions...
To guide this process, a cost can be associated to each symbol (terminal
or non-terminal), and the cost of the recovery will be the sum of the cost
of all symbols in the generated sentence. *)
(** Symbol cost
The `recover.cost` attribute is attached to the definition of symbols
(terminals and non-terminals) and takes a floating point value.
%token PLUS [@recover.cost 1.0]
expr [@recover.cost 1.0]: ... ; *)
val cost_of_symbol : G.symbol -> Cost.t
(** Cost of a grammar symbol *)
(** Item cost
The cost can be applied to a specific item (an occurrence of a symbol in a
rule).
In this case, the more specific cost will replace the global cost for this
specific occurrence.
expr: | INT PLUS [@recover.cost 0.0] INT \{ ... \} | INT TIMES
[@recover.cost 10.0] INT \{ ... \} ;
In this example, if an error happens just after an integer in an
expression, the `PLUS` rule will be favored over the `TIMES` rule because
the first token is more expensive. *)
val penalty_of_item : G.production * int -> Cost.t
(** Penalty (added cost) for shifting an item *)
(** Reduction cost
The last place where a `recover.cost` is accepted is in a production. This
is convenient to prevent the recovery to trigger some semantic actions.
expr: LPAREN expr error \{ ... \} [@recover.cost infinity] ;
It would not make much sense for the recovery to select an error rule.
Associating an infinite cost to the production ensures that this never
happen. *)
val cost_of_prod : G.production -> Cost.t
(** Cost of reducing a production *)
(** Meaning of costs
The cost should be a positive floating-point value. +∞ and 0.0 are
accepted.
If not specified, the default cost depends on the presence of a semantic
value:
- for a terminal without semantic value (such as `%token DOT`) it is 0.0.
- for a terminal with a semantic value (such as `%token<int> INT`) or a
non-terminal it is +∞.
If the attribute happens multiple times, the sum of all occurrences is
used.
**TODO**: specify how null values are treated with respect to minimal
cost, can the algorithm diverge? *)
(** Recovery expressions
Symbols with a semantic value cannot be picked by the recovery algorithm
if it does not know how to produce this value.
The `recover.expr` attribute associates an ocaml expression to a symbol.
This expression should evaluate to a semantic value for this symbol.
%token<string> IDENT [@recover.expr "invalid-identifier"]
When applied to non-terminals, it is particularly useful to produce a
value that could not be the result of a normal parse.
expr [@recover.expr Invalid_expression]: ... ;
Here `Invalid_expression` is a node added to the AST for the purpose of
identifying parts that were recovered.
Furthermore, specifying fallback values for non-terminals prevents
Menhir-recover from generating a hardly predictable sequence of tokens
just for filling holes in the AST. *)
val default_terminal : G.terminal -> string option
(** An optional ocaml expression that should evaluate to a semantic value
valid for this terminal. *)
val default_nonterminal : G.nonterminal -> string option
(** An optional ocaml expression that should evaluate to a semantic value
valid for this non-terminal. *)
(** The expressions are evaluated every time a new instance of a symbol is
needed, although it is not specified whether every evaluation will be kept
in the final solution (at run time, the algorithm is free to explore
different branches and throw them away as needed).
**TODO**: decide how information can be communicated with recovery
expressions (for instance the current location of the parser) *)
(** Recovery prelude
The `recover.prelude` attribute is attached to the grammar.
It is an arbitrary piece of OCaml code that will be inserted before the
code of `recover.expr` expressions.
It is useful for defining definitions shared by the recovery expressions,
in the same way as `%\{ ... %\}` is used to share definitions in semantic
actions of the grammar. *)
val default_prelude : Format.formatter -> unit
(** Output the grammar prelude in this formatter *)
end
module Recover_attributes (G : MenhirSdk.Cmly_api.GRAMMAR) :
ATTRIBUTES with module G = G = struct
module G = G
open G
let string_starts_with str ~prefix =
let len = String.length prefix in
String.length str >= len
&&
try
for i = 0 to len - 1 do
if str.[i] <> prefix.[i] then raise Exit
done;
true
with
| Exit -> false
let prefix = "recover."
let all_attributes = [ "recover.cost"; "recover.expr"; "recover.prelude" ]
let validate_attribute accepted kind attr =
let label = Attribute.label attr in
if string_starts_with ~prefix label && not (List.mem label ~set:accepted)
then
let split_pos pos =
( pos.Lexing.pos_fname
, pos.Lexing.pos_lnum
, pos.Lexing.pos_cnum - pos.Lexing.pos_bol )
in
let range () range =
let s = Printf.sprintf in
let sf, sl, sc = split_pos (Range.startp range) in
let ef, el, ec = split_pos (Range.endp range) in
if sf <> ef
then s "%s:%d.%d-%s:%d.%d" sf sl sc ef el ec
else if sl <> el
then s "%s:%d.%d-%d.%d" sf sl sc el ec
else if sc <> ec
then s "%s:%d.%d-%d" sf sl sc ec
else s "%s:%d.%d" sf sl sc
in
let f fmt = Printf.ksprintf prerr_endline fmt in
if List.mem label ~set:all_attributes
then
f
"%a: attribute %S cannot be put in %s"
range
(Attribute.position attr)
label
kind
else
f
"%a: attribute %S is not recognized (found in %s)"
range
(Attribute.position attr)
label
kind
let validate_attributes accepted kind attrs =
List.iter ~f:(validate_attribute accepted kind) attrs
let () =
validate_attributes
[ "recover.prelude" ]
"grammar attributes"
Grammar.attributes;
let symbol prj attrs =
validate_attributes
[ "recover.cost"; "recover.expr" ]
"symbol attributes"
(prj attrs)
in
Nonterminal.iter (symbol G.Nonterminal.attributes);
Terminal.iter (symbol G.Terminal.attributes);
Production.iter (fun p ->
validate_attributes
[ "recover.cost"
; (* recover.expr: a lie to prevent warnings on an unfortunate
interaction between menhir inlining and attributes *)
"recover.expr"
]
"production attributes"
(Production.attributes p);
Array.iter
~f:(fun (_, _, attrs) ->
validate_attributes [ "recover.cost" ] "item attributes" attrs)
(Production.rhs p))
let cost_of_attributes prj attrs =
Cost.of_int
(List.fold_left (prj attrs) ~init:0 ~f:(fun total attr ->
if Attribute.has_label "recover.cost" attr
then total + int_of_string (Attribute.payload attr)
else total))
let cost_of_symbol =
let measure ~has_default prj attrs =
if
List.exists ~f:(Attribute.has_label "recover.expr") (prj attrs)
|| has_default
then cost_of_attributes prj attrs
else Cost.infinite
in
let ft =
Terminal.tabulate (fun t ->
measure ~has_default:(Terminal.typ t = None) Terminal.attributes t)
in
let fn =
Nonterminal.tabulate (measure ~has_default:false Nonterminal.attributes)
in
function
| T t -> (match Terminal.kind t with `ERROR -> Cost.infinite | _ -> ft t)
| N n -> fn n
let cost_of_prod =
Production.tabulate (cost_of_attributes Production.attributes)
let penalty_of_item =
let f =
Production.tabulate @@ fun p ->
Array.map ~f:(cost_of_attributes (fun (_, _, a) -> a)) (Production.rhs p)
in
fun (p, i) ->
let costs = f p in
if i < Array.length costs then costs.(i) else cost_of_prod p
let default_prelude ppf =
List.iter
~f:(fun a ->
if Attribute.has_label "recover.prelude" a
then Format.fprintf ppf "%s\n" (Attribute.payload a))
Grammar.attributes
let default_expr ?(fallback = "raise Not_found") attrs =
match List.find ~f:(Attribute.has_label "recover.expr") attrs with
| exception Not_found -> fallback
| attr -> Attribute.payload attr
let default_terminal t =
match Terminal.kind t with
| `REGULAR | `ERROR | `EOF ->
let fallback =
match Terminal.typ t with None -> Some "()" | Some _ -> None
in
Some (default_expr ?fallback (Terminal.attributes t))
| `PSEUDO -> None
let default_nonterminal n =
match Nonterminal.kind n with
| `REGULAR -> Some (default_expr (Nonterminal.attributes n))
| `START -> None
end
================================================
FILE: src/menhir-recover/attributes.mli
================================================
(* Attributes guide the recovery .
Some information can be passed to Menhir-recover via attributes. These are
pieces of string that are ignored by Menhir itself and are transmitted to
Menhir-recover.
The attributes that are relevant to Menhir-recover are always prefixed with
`recover.`. An attribute with the same prefix and that is not understood by
Menhir-recover will produce a warning message (to detect a typo or a
misplaced attribute). *)
(** Specification of attributes that are meaningful for recovery *)
module type ATTRIBUTES = sig
module G : MenhirSdk.Cmly_api.GRAMMAR
(** The Menhir grammar to which these apply *)
(** Recovery cost
When the parser is in an error state, Menhir-recover will invent some
input that recovers from this error. In most grammars, this problem has
many solutions, often an infinity.
But not all solutions are equally nice. Some will have repetitions, some
will generate undesirable AST nodes or trigger error reductions...
To guide this process, a cost can be associated to each symbol (terminal
or non-terminal), and the cost of the recovery will be the sum of the cost
of all symbols in the generated sentence. *)
(** Symbol cost
The `recover.cost` attribute is attached to the definition of symbols
(terminals and non-terminals) and takes a floating point value.
%token PLUS [@recover.cost 1.0]
expr [@recover.cost 1.0]: ... ; *)
val cost_of_symbol : G.symbol -> Cost.t
(** Cost of a grammar symbol *)
(** Item cost
The cost can be applied to a specific item (an occurrence of a symbol in a
rule).
In this case, the more specific cost will replace the global cost for this
specific occurrence.
expr: | INT PLUS [@recover.cost 0.0] INT \{ ... \} | INT TIMES
[@recover.cost 10.0] INT \{ ... \} ;
In this example, if an error happens just after an integer in an
expression, the `PLUS` rule will be favored over the `TIMES` rule because
the first token is more expensive. *)
val penalty_of_item : G.production * int -> Cost.t
(** Penalty (added cost) for shifting an item *)
(** Reduction cost
The last place where a `recover.cost` is accepted is in a production. This
is convenient to prevent the recovery to trigger some semantic actions.
expr: LPAREN expr error \{ ... \} [@recover.cost infinity] ;
It would not make much sense for the recovery to select an error rule.
Associating an infinite cost to the production ensures that this never
happen. *)
val cost_of_prod : G.production -> Cost.t
(** Cost of reducing a production *)
(** Meaning of costs
The cost should be a positive floating-point value. +∞ and 0.0 are
accepted.
If not specified, the default cost depends on the presence of a semantic
value:
- for a terminal without semantic value (such as `%token DOT`) it is 0.0.
- for a terminal with a semantic value (such as `%token<int> INT`) or a
non-terminal it is +∞.
If the attribute happens multiple times, the sum of all occurrences is
used.
**TODO**: specify how null values are treated with respect to minimal
cost, can the algorithm diverge? *)
(** Recovery expressions
Symbols with a semantic value cannot be picked by the recovery algorithm
if it does not know how to produce this value.
The `recover.expr` attribute associates an ocaml expression to a symbol.
This expression should evaluate to a semantic value for this symbol.
%token<string> IDENT [@recover.expr "invalid-identifier"]
When applied to non-terminals, it is particularly useful to produce a
value that could not be the result of a normal parse.
expr [@recover.expr Invalid_expression]: ... ;
Here `Invalid_expression` is a node added to the AST for the purpose of
identifying parts that were recovered.
Furthermore, specifying fallback values for non-terminals prevents
Menhir-recover from generating a hardly predictable sequence of tokens
just for filling holes in the AST. *)
val default_terminal : G.terminal -> string option
(** An optional ocaml expression that should evaluate to a semantic value
valid for this terminal. *)
val default_nonterminal : G.nonterminal -> string option
(** An optional ocaml expression that should evaluate to a semantic value
valid for this non-terminal. *)
(** The expressions are evaluated every time a new instance of a symbol is
needed, although it is not specified whether every evaluation will be kept
in the final solution (at run time, the algorithm is free to explore
different branches and throw them away as needed).
**TODO**: decide how information can be communicated with recovery
expressions (for instance the current location of the parser) *)
(** Recovery prelude
The `recover.prelude` attribute is attached to the grammar.
It is an arbitrary piece of OCaml code that will be inserted before the
code of `recover.expr` expressions.
It is useful for defining definitions shared by the recovery expressions,
in the same way as `%\{ ... %\}` is used to share definitions in semantic
actions of the grammar. *)
val default_prelude : Format.formatter -> unit
(** Output the grammar prelude in this formatter *)
end
module Recover_attributes (G : MenhirSdk.Cmly_api.GRAMMAR) :
ATTRIBUTES with module G = G
================================================
FILE: src/menhir-recover/cost.ml
================================================
type t = int
let zero = 0
let infinite = max_int
let compare : t -> t -> int = compare
let add t1 t2 =
let result = t1 + t2 in
if result < 0 then infinite else result
let of_int x =
if x < 0 then invalid_arg "Cost.of_int: cost must be positive" else x
let to_int x = x
let is_infinite x = x = infinite
let arg_min f a b = if compare (f a) (f b) <= 0 then a else b
let pp = Format.pp_print_int
================================================
FILE: src/menhir-recover/cost.mli
================================================
type t
val zero : t
val infinite : t
val compare : t -> t -> int
val add : t -> t -> t
val of_int : int -> t
val to_int : t -> int
val is_infinite : t -> bool
val arg_min : ('a -> t) -> 'a -> 'a -> 'a
val pp : Format.formatter -> t -> unit
================================================
FILE: src/menhir-recover/dune
================================================
(executable
(name menhir_recover)
(flags :standard -open StdLabels)
(libraries fix menhirLib menhirSdk))
================================================
FILE: src/menhir-recover/emitter.ml
================================================
open Recovery_intf
let menhir = "MenhirInterpreter"
(* Generation scheme doing checks and failing at runtime, or not ... *)
let safe = false
type var = int
module Codesharing
(G : MenhirSdk.Cmly_api.GRAMMAR)
(S : Synthesis.SYNTHESIZER with module G := G)
(R : RECOVERY with module G := G) : sig
type instr =
| IRef of var
| IAbort
| IReduce of G.production
| IShift of G.symbol
val compile : R.item list -> instr list list * (R.item -> instr list)
end = struct
open S
(* Rewrite trivial indirections: Seq [x] => x ys @ [Seq xs] => ys @ xs *)
let rec normalize_actions = function
| [] -> []
| [ Seq v ] -> normalize_actions v
| x :: xs -> normalize_action x :: normalize_actions xs
and normalize_action = function
| (Abort | Reduce _ | Shift _) as a -> a
| Seq [ v ] -> normalize_action v
| Seq v -> (match normalize_actions v with [ x ] -> x | xs -> Seq xs)
(* Find sharing opportunities. If the same sequence of actions occurs multiple
times, the function will associate a unique identifier to the sequence.
[share actions] returns a pair [(bindings, lookup) : action list array *
(action list -> int option)]
The [bindings] array contains all action lists that are worth sharing. The
[lookup] function returns the index of an action list if is is in the
array. *)
let share actions =
let occurrence_table = Hashtbl.create 113 in
(let order = ref 0 in
let rec iter_list = function
| [] | [ _ ] -> ()
| x :: xs as xxs ->
(match Hashtbl.find occurrence_table xxs with
| occurrences, _index -> incr occurrences
| exception Not_found ->
let index = ref (-1) in
Hashtbl.add occurrence_table xxs (ref 1, index);
iter x;
iter_list xs;
index := !order;
incr order)
and iter = function
| Abort | Reduce _ | Shift _ -> ()
| Seq xs -> iter_list xs
in
List.iter ~f:iter_list actions);
let bindings =
let register actions (occurrences, index) to_share =
if !occurrences > 1 then (!index, actions) :: to_share else to_share
in
let to_share = Hashtbl.fold register occurrence_table [] in
let order_actions (o1, _) (o2, _) = compare o1 (o2 : int) in
List.map ~f:snd (List.sort ~cmp:order_actions to_share)
in
let binding_table = Hashtbl.create 113 in
List.iteri
~f:(fun idx actions -> Hashtbl.add binding_table actions idx)
bindings;
let lookup actions =
match Hashtbl.find binding_table actions with
| exception Not_found -> None
| index -> Some index
in
bindings, lookup
let item_to_actions (st, prod, pos) =
normalize_actions (snd (S.solve (Tail (st, prod, pos))))
type instr =
| IRef of int
| IAbort
| IReduce of G.production
| IShift of G.symbol
let rec compile_one ~sharing = function
| Abort -> [ IAbort ]
| Reduce p -> [ IReduce p ]
| Shift s -> [ IShift s ]
| Seq xs -> share_seq ~sharing xs
and share_seq ~sharing seq =
match sharing seq with
| None -> compile_seq ~sharing seq
| Some index -> [ IRef index ]
and compile_seq ~sharing = function
| [] -> []
| x :: xs ->
let x' = compile_one ~sharing x in
let xs' = share_seq ~sharing xs in
x' @ xs'
let compile items =
let actions = List.map ~f:item_to_actions items in
let bindings, sharing = share actions in
let bindings = List.map ~f:(compile_seq ~sharing) bindings in
let compile_item item = share_seq ~sharing (item_to_actions item) in
bindings, compile_item
end
module Make
(G : MenhirSdk.Cmly_api.GRAMMAR)
(A : Attributes.ATTRIBUTES with module G := G)
(S : Synthesis.SYNTHESIZER with module G := G)
(R : RECOVERY with module G := G) : sig
val emit : Format.formatter -> unit
end = struct
open G
open Format
let emit_default_value ppf =
fprintf
ppf
"open %s\n\n"
(String.capitalize_ascii (Filename.basename Grammar.basename));
fprintf ppf "module Default = struct\n";
A.default_prelude ppf;
fprintf ppf " let value (type a) : a %s.symbol -> a = function\n" menhir;
Terminal.iter (fun t ->
match A.default_terminal t with
| None -> ()
| Some str ->
fprintf
ppf
" | %s.T %s.T_%s -> %s\n"
menhir
menhir
(Terminal.name t)
str);
Nonterminal.iter (fun n ->
match A.default_nonterminal n with
| None -> ()
| Some str ->
fprintf
ppf
" | %s.N %s.N_%s -> %s\n"
menhir
menhir
(Nonterminal.mangled_name n)
str);
(*fprintf ppf " | _ -> raise Not_found\n"; should be exhaustive*)
fprintf ppf "end\n\n";
fprintf ppf "let default_value = Default.value\n\n"
let emit_defs ppf =
fprintf ppf "open %s\n\n" menhir;
fprintf
ppf
"type action =\n\
\ | Abort\n\
\ | R of int\n\
\ | S : 'a symbol -> action\n\
\ | Sub of action list\n\n";
fprintf
ppf
"type decision =\n\
\ | Nothing\n\
\ | One of action list\n\
\ | Select of (int -> action list)\n\n"
let emit_depth ppf =
let open Format in
fprintf ppf "let depth =\n [|";
Lr1.iter (fun st ->
let items = G.Lr0.items (G.Lr1.lr0 st) in
let positions = List.map ~f:snd items in
let depth = List.fold_left positions ~init:0 ~f:max in
fprintf ppf "%d;" depth);
fprintf ppf "|]\n\n"
let emit_can_pop ppf =
Format.fprintf ppf "let can_pop (type a) : a terminal -> bool = function\n";
G.Terminal.iter (fun t ->
if G.Terminal.kind t = `REGULAR && G.Terminal.typ t = None
then Format.fprintf ppf " | T_%s -> true\n" (G.Terminal.name t));
Format.fprintf ppf " | _ -> false\n\n"
module C = Codesharing (G) (S) (R)
let emit_recoveries =
let rec list_last = function
| [ x ] -> x
| _ :: xs -> list_last xs
| [] -> invalid_arg "list_last"
in
fun ppf ->
let all_cases =
Lr1.fold
(fun st acc ->
try
let { R.cases; _ } = R.recover st in
let cases =
List.map
~f:(fun (st', items) ->
( list_last items
, match st' with None -> -1 | Some st' -> Lr1.to_int st' ))
cases
in
let cases =
match Synthesis.group_assoc cases with
| [] -> `Nothing
| [ (instr, _) ] -> `One instr
| xs -> `Select xs
in
(cases, Lr1.to_int st) :: acc
with
| _ -> acc)
[]
in
let all_cases = Synthesis.group_assoc all_cases in
let all_items =
let items_in_case (case, _states) =
match case with
| `Nothing -> []
| `One item -> [ item ]
| `Select items -> List.map ~f:fst items
in
List.flatten (List.map ~f:items_in_case all_cases)
in
let globals, get_instr = C.compile all_items in
let open Format in
fprintf ppf "let recover =\n";
let emit_instr ppf = function
| C.IAbort -> fprintf ppf "Abort"
| C.IReduce prod -> fprintf ppf "R %d" (Production.to_int prod)
| C.IShift (T t) -> fprintf ppf "S (T T_%s)" (Terminal.name t)
| C.IShift (N n) ->
fprintf ppf "S (N N_%s)" (Nonterminal.mangled_name n)
| C.IRef r -> fprintf ppf "r%d" r
in
let emit_instrs ppf = Synthesis.pp_list ~f:emit_instr ppf in
let emit_shared index instrs =
fprintf ppf " let r%d = Sub %a in\n" index emit_instrs instrs
in
List.iteri ~f:emit_shared globals;
let emit_item ppf item = emit_instrs ppf (get_instr item) in
fprintf ppf " function\n";
List.iter
~f:(fun (cases, states) ->
fprintf ppf " ";
List.iter ~f:(fprintf ppf "| %d ") states;
fprintf ppf "-> ";
match cases with
| `Nothing -> fprintf ppf "Nothing\n"
| `One item -> fprintf ppf "One %a\n" emit_item item
| `Select xs ->
fprintf ppf "Select (function\n";
if safe
then (
List.iter
~f:(fun (item, cases) ->
fprintf ppf " ";
List.iter ~f:(fprintf ppf "| %d ") cases;
fprintf ppf "-> %a\n" emit_item item)
xs;
fprintf ppf " | _ -> raise Not_found)\n")
else (
match
List.sort
~cmp:(fun (_, a) (_, b) ->
compare (List.length b) (List.length a))
xs
with
| (item, _) :: xs ->
List.iter
~f:(fun (item, cases) ->
fprintf ppf " ";
List.iter ~f:(fprintf ppf "| %d ") cases;
fprintf ppf "-> %a\n" emit_item item)
xs;
fprintf ppf " | _ -> %a)\n" emit_item item
| [] -> assert false))
all_cases;
fprintf ppf " | _ -> raise Not_found\n"
let emit_token_of_terminal ppf =
let case t =
match Terminal.kind t with
| `REGULAR | `EOF ->
fprintf
ppf
" | %s.T_%s -> %s%s\n"
menhir
(Terminal.name t)
(Terminal.name t)
(if Terminal.typ t <> None then " v" else "")
| `ERROR ->
fprintf ppf " | %s.T_%s -> assert false\n" menhir (Terminal.name t)
| `PSEUDO -> ()
in
fprintf
ppf
"let token_of_terminal (type a) (t : a %s.terminal) (v : a) : token =\n\
\ match t with\n"
menhir;
Terminal.iter case
let emit_nullable ppf =
let print_n n =
if Nonterminal.nullable n
then fprintf ppf " | N_%s -> true\n" (Nonterminal.mangled_name n)
in
fprintf
ppf
"let nullable (type a) : a MenhirInterpreter.nonterminal -> bool =\n\
\ let open MenhirInterpreter in function\n";
Nonterminal.iter print_n;
fprintf ppf " | _ -> false\n"
let emit ppf =
emit_default_value ppf;
emit_defs ppf;
emit_depth ppf;
emit_can_pop ppf;
emit_recoveries ppf;
emit_token_of_terminal ppf;
emit_nullable ppf
end
================================================
FILE: src/menhir-recover/emitter.mli
================================================
open MenhirSdk.Cmly_api
open Attributes
open Synthesis
open Recovery_intf
module Make
(G : GRAMMAR)
(_ : ATTRIBUTES with module G := G)
(_ : SYNTHESIZER with module G := G)
(_ : RECOVERY with module G := G) : sig
val emit : Format.formatter -> unit
end
================================================
FILE: src/menhir-recover/menhir_recover.ml
================================================
open MenhirSdk
open Recovery_custom
let name = ref ""
let verbose = ref false
let usage () =
Printf.eprintf "Usage: %s [-v] file.cmly\n" Sys.argv.(0);
exit 1
let () =
for i = 1 to Array.length Sys.argv - 1 do
match Sys.argv.(i) with
| "-v" -> verbose := true
| arg -> if !name = "" then name := arg else usage ()
done;
if !name = "" then usage ()
module G = Cmly_read.Read (struct
let filename = !name
end)
module A = Attributes.Recover_attributes (G)
let () =
let open Format in
let ppf = Format.err_formatter in
if !verbose
then (
let open G in
Lr1.iter (fun (st : lr1) ->
fprintf ppf "\n# LR(1) state #%d\n\n" (st :> int);
fprintf ppf "Items:\n";
Print.itemset ppf (Lr0.items (Lr1.lr0 st));
fprintf ppf "Transitions:\n";
List.iter
~f:(fun (sym, (st' : lr1)) ->
fprintf ppf " - on %a, goto #%d\n" Print.symbol sym (st' :> int))
(Lr1.transitions st);
fprintf ppf "Reductions:\n";
List.iter
~f:(fun (t, ps) ->
let p : production = List.hd ps in
fprintf
ppf
" - on %a, reduce %d:\n %a\n"
Print.terminal
t
(p :> int)
Print.production
p)
(Lr1.reductions st [@alert "-deprecated"]));
Production.iter (fun (p : production) ->
fprintf ppf "\n# Production p%d\n%a" (p :> int) Print.production p))
module S = Synthesis.Synthesizer (G) (A)
let () = if !verbose then S.report Format.err_formatter
module R = Recover (G) (S)
(*let () = if !verbose then R.report Format.err_formatter*)
module E = Emitter.Make (G) (A) (S) (R)
let () = E.emit Format.std_formatter
================================================
FILE: src/menhir-recover/recovery_custom.ml
================================================
module type RECOVERY = sig
module G : MenhirSdk.Cmly_api.GRAMMAR
type item = G.lr1 * G.production * int
type recovery =
{ prefix : int
; cases : (G.lr1 option * item list) list
}
(** [prefix] is the size of the known prefix of the stack. It means that in
the kernel of current state, there is an item whose dot is at position
[prefix]. (we know the incoming symbols for these stack frames and we can
enumerate the possible state numbers).
[cases] is a mapping that associates to each possible state found at
stack.[-prefix] (or None if the stack is empty) a list of reductions to
execute.
The actual list of actions to reduce an item [(state, prod, pos)] is given
by [Synthesizer.solution (Trail (state, prod, pos))] *)
val recover : G.lr1 -> recovery
val report : Format.formatter -> unit
end
module Recover
(G : MenhirSdk.Cmly_api.GRAMMAR)
(S : Synthesis.SYNTHESIZER with module G := G) :
RECOVERY with module G := G = struct
open G
type item = lr1 * production * int
type recovery =
{ prefix : int
; cases : (G.lr1 option * item list) list
}
type trace =
{ cost : Cost.t
; items : item list
}
module Trace = struct
type t = trace
let min tr1 tr2 = Cost.arg_min (fun t -> t.cost) tr1 tr2
let cat tr1 tr2 =
{ cost = Cost.add tr1.cost tr2.cost; items = tr1.items @ tr2.items }
end
module State = struct
type level = (nonterminal * Trace.t) list
type t = level list
let rec merge_level l1 l2 : level =
match l1, l2 with
| [], l -> l
| l, [] -> l
| (nt1, c1) :: xs1, x2 :: xs2 ->
let nt2, c2 = x2 in
(match compare nt1 nt2 with
| 0 ->
let x = nt1, Trace.min c1 c2 in
x :: merge_level xs1 xs2
| n when n > 0 -> x2 :: merge_level l1 xs2
| _ -> (nt1, c1) :: merge_level xs1 l2)
let rec merge l1 l2 : t =
match l1, l2 with
| [], l -> l
| l, [] -> l
| x1 :: l1, x2 :: l2 ->
let x' = merge_level x1 x2 in
x' :: merge l1 l2
end
let synthesize =
let rec add_nt tr nt = function
| [] -> [ nt, tr ]
| x :: xs ->
(match compare nt (fst x) with
| 0 -> (nt, Trace.min tr (snd x)) :: xs
| c when c < 0 -> (nt, tr) :: xs
| _ -> x :: add_nt tr nt xs)
in
let add_item cost item stack =
let _, prod, pos = item in
if Cost.is_infinite cost
then stack
else
let stack_hd = function [] -> [] | x :: _ -> x
and stack_tl = function [] -> [] | _ :: xs -> xs in
let rec aux stack = function
| 0 ->
add_nt
{ cost; items = [ item ] }
(Production.lhs prod)
(stack_hd stack)
:: stack_tl stack
| n -> stack_hd stack :: aux (stack_tl stack) (n - 1)
in
aux stack pos
in
Lr1.tabulate (fun st ->
List.fold_left
(Lr0.items (Lr1.lr0 st))
~init:[]
~f:(fun acc (prod, pos) ->
if pos = 0
then acc
else
let cost, _actions = S.solve (S.Tail (st, prod, pos)) in
add_item cost (st, prod, pos) acc))
let step st ntss =
let seen = ref Bytes.empty in
let mem n =
let off = n lsr 3
and mask = 1 lsl (n land 7) in
Bytes.length !seen > off && Char.code (Bytes.get !seen off) land mask <> 0
in
let mark_seen n =
let off = n lsr 3
and mask = 1 lsl (n land 7) in
let len = Bytes.length !seen in
if len <= off
then seen := Bytes.cat !seen (Bytes.make (off + 1 - len) '\000');
let code = Char.code (Bytes.get !seen off) lor mask in
Bytes.set !seen off (Char.chr code)
in
let rec aux = function
| [] -> []
| ((nt, tr) :: x) :: xs
when (not (mem (Nonterminal.to_int nt)))
&& not (Nonterminal.kind nt = `START) ->
mark_seen (Nonterminal.to_int nt);
let st' = List.assoc (N nt) (Lr1.transitions st) in
let xs' = synthesize st' in
let xs' = match xs' with [] -> [] | _ :: xs -> xs in
let merge_trace (nt, tr') = nt, Trace.cat tr' tr in
let xs' = List.map ~f:(List.map ~f:merge_trace) xs' in
aux (State.merge xs' (x :: xs))
| (_ :: x) :: xs -> aux (x :: xs)
| [] :: xs -> xs
in
aux ntss
let init st = (st, [ st ]), step st (synthesize st)
let pred =
(* Compute lr1 predecessor relation *)
let tbl1 = Array.make Lr1.count [] in
let revert_transition s1 (sym, s2) =
assert (
match Lr0.incoming (Lr1.lr0 s2) with
| None -> false
| Some sym' -> sym = sym');
tbl1.(Lr1.to_int s2) <- s1 :: tbl1.(Lr1.to_int s2)
in
Lr1.iter (fun lr1 ->
List.iter ~f:(revert_transition lr1) (Lr1.transitions lr1));
fun lr1 -> tbl1.(Lr1.to_int lr1)
let expand stuck_states ((st, sts), nts) =
List.map
~f:(fun st' ->
let nts' = step st' nts in
if nts' = [] then stuck_states := st' :: !stuck_states;
(st', st' :: sts), nts')
(pred st)
let all_stuck_states : (Lr1.t, int ref) Hashtbl.t = Hashtbl.create 7
let recover st : recovery =
(* How big is the known prefix of the stack *)
let known_prefix =
let items = Lr0.items (Lr1.lr0 st) in
List.fold_left
(List.tl items)
~init:(snd (List.hd items))
~f:(fun pos (_, pos') -> max pos pos')
in
(* Walk this prefix *)
let stuck = ref false in
let stuck_states = ref [] in
let traces =
let acc = ref [ init st ] in
for _i = 1 to known_prefix - 1 do
acc := List.concat (List.map ~f:(expand stuck_states) !acc)
done;
!acc
in
(*Printf.printf "trace(%d): %d items\n%!" (Lr1.to_int st) (List.length
traces);*)
(* Last step *)
let process_trace trace =
match expand stuck_states trace with
| [] ->
(* Initial state *)
assert (snd trace = []);
[]
| states ->
let select_trace traces =
(* Pick a trace with minimal cost, somewhat arbitrary *)
match List.flatten traces with
| [] ->
List.iter
~f:(fun st ->
let r =
try Hashtbl.find all_stuck_states st with
| Not_found ->
let r = ref 0 in
Hashtbl.add all_stuck_states st r;
r
in
incr r)
!stuck_states;
stuck := true;
stuck_states := [];
None
| (_, trace) :: alternatives ->
Some
(List.fold_left alternatives ~init:trace ~f:(fun tr1 (_, tr2) ->
Trace.min tr1 tr2))
in
let select_expansion = function
| _, [] ->
(* Reached stack bottom *)
None, select_trace (snd trace)
| (st, _sts), trace' -> Some st, select_trace trace'
in
List.map ~f:select_expansion states
in
let cases =
List.flatten
@@ List.map
~f:(fun trace ->
List.fold_right
(process_trace trace)
~init:[]
~f:(fun (st, tr') acc ->
match tr' with
| Some { items; _ } -> (st, items) :: acc
| None -> acc))
traces
in
if !stuck
then
Format.printf
"Not enough annotation to recover from state %d:\n%a\n%!"
(Lr1.to_int st)
Print.itemset
(Lr0.items (Lr1.lr0 st));
{ prefix = known_prefix; cases }
let recover = Lr1.tabulate recover
let () =
let all_stuck_states =
Hashtbl.fold (fun k v acc -> (k, !v) :: acc) all_stuck_states []
in
let all_stuck_states =
List.sort ~cmp:(fun (_, v1) (_, v2) -> compare v2 v1) all_stuck_states
in
List.iter
~f:(fun (st, count) ->
Format.printf
"# State %d is preventing recovery from %d states:\n%a\n\n%!"
(Lr1.to_int st)
count
Print.itemset
(Lr0.items (Lr1.lr0 st)))
all_stuck_states
let report _ppf = ()
end
================================================
FILE: src/menhir-recover/recovery_custom.mli
================================================
module type RECOVERY = sig
module G : MenhirSdk.Cmly_api.GRAMMAR
type item = G.lr1 * G.production * int
type recovery =
{ prefix : int
; cases : (G.lr1 option * item list) list
}
(** [prefix] is the size of the known prefix of the stack. It means that in
the kernel of current state, there is an item whose dot is at position
[prefix]. (we know the incoming symbols for these stack frames and we can
enumerate the possible state numbers).
[cases] is a mapping that associates to each possible state found at
stack.[-prefix] (or None if the stack is empty) a list of reductions to
execute.
The actual list of actions to reduce an item [(state, prod, pos)] is given
by [Synthesizer.solution (Trail (state, prod, pos))] *)
val recover : G.lr1 -> recovery
val report : Format.formatter -> unit
end
module Recover
(G : MenhirSdk.Cmly_api.GRAMMAR)
(_ : Synthesis.SYNTHESIZER with module G := G) : RECOVERY with module G := G
================================================
FILE: src/menhir-recover/recovery_intf.ml
================================================
module type RECOVERY = sig
module G : MenhirSdk.Cmly_api.GRAMMAR
type item = G.lr1 * G.production * int
type recovery =
{ prefix : int
; cases : (G.lr1 option * item list) list
}
(** [prefix] is the size of the known prefix of the stack. It means that in
the kernel of current state, there is an item whose dot is at position
[prefix]. (we know the incoming symbols for these stack frames and we can
enumerate the possible state numbers).
[cases] is a mapping that associates to each possible state found at
stack.[-prefix] (or None if the stack is empty) a list of reductions to
execute.
The actual list of actions to reduce an item [(state, prod, pos)] is given
by [Synthesizer.solution (Trail (state, prod, pos))] *)
val recover : G.lr1 -> recovery
end
================================================
FILE: src/menhir-recover/synthesis.ml
================================================
open MenhirSdk.Cmly_api
open Attributes
let group_assoc l =
let cons k v acc = (k, List.rev v) :: acc in
let rec aux k v vs acc = function
| [] -> List.rev (cons k (v :: vs) acc)
| (k', v') :: xs when compare k k' = 0 ->
if compare v v' = 0 then aux k v vs acc xs else aux k v' (v :: vs) acc xs
| (k', v') :: xs -> aux k' v' [] (cons k (v :: vs) acc) xs
in
match List.sort ~cmp:compare l with
| [] -> []
| (k, v) :: xs -> aux k v [] [] xs
let pp_list ~f ppf = function
| [] -> Format.fprintf ppf "[]"
| x :: xs ->
Format.fprintf ppf "[%a" f x;
List.iter ~f:(Format.fprintf ppf "; %a" f) xs;
Format.fprintf ppf "]"
(** Specification of synthesized tactics *)
module type SYNTHESIZER = sig
module G : GRAMMAR
(* Specification of problems
There are two situations we want to synthesize solution for:
- `Head` is when the dot is just in front of some non-terminal, and we
would like to find a way to move the dot to the right of this symbol (by
executing a sequence of actions that results in this non-terminal being
pushed on the stack)
- `Tail` is when the dot is in some production that we would like to
reduce. *)
type variable =
| Head of G.lr1 * G.nonterminal
| Tail of G.lr1 * G.production * int
(* The integer parameter in `Tail` is the position of the dot in the
production we are trying to reduce. This is necessary to uniquely identify
a production that occurs multiple time in a state.
For instance, in the grammar:
%token<int> INT %token PLUS
expr: | INT \{ $1 \} (*const*) | expr PLUS expr \{ $1 + $2 \} (*add*)
Synthesizing `Head (st0, expr)` when `expr PLUS . expr` is in `st0` will
output the actions to get to the state `st'` containing `expr PLUS expr .`.
Synthesizing `Tail (st1, add, 1)` when `expr . PLUS expr` is in `st1` will
output the actions that end up reducing `add` (which will likely be
shifting `PLUS`, synthesizing `Head (st0, expr)` and reducing add). *)
val variable_to_string : variable -> string
(** A human readable representation of a [variable]. *)
(** Specification of solutions
A successful synthesis results in a list of actions. *)
type action =
| Abort
| Reduce of G.production
| Shift of G.symbol
| Seq of action list
(* `Abort` is issued if there is no solution. This is the case for instance if
there is a semantic value that the synthesizer cannot produce, or a
production with an infinite cost.
`Shift` and `Reduce` are direct actions to execute on the parser.
`Seq` is a sequence of action. *)
val action_to_string : action -> string
(** A human readable representation of an action. *)
val solve : variable -> Cost.t * action list
(** Give the solution found for a variable as a list of action. *)
val report : Format.formatter -> unit
(** Print the solutions or absence thereof for the whole grammar. *)
end
(** Synthesizer implementation *)
module Synthesizer (G : GRAMMAR) (A : ATTRIBUTES with module G = G) :
SYNTHESIZER with module G := G = struct
open G
type variable =
| Head of lr1 * nonterminal
| Tail of lr1 * production * int
let variable_to_string = function
| Head (st, n) ->
Printf.sprintf "Head (#%d, %s)" (Lr1.to_int st) (Nonterminal.name n)
| Tail (st, prod, pos) ->
Printf.sprintf
"Tail (#%d, p%d, %d)"
(Lr1.to_int st)
(Production.to_int prod)
pos
type action =
| Abort
| Reduce of production
| Shift of symbol
| Seq of action list
let rec action_to_string = function
| Abort -> "Abort"
| Reduce prod -> "Reduce p" ^ string_of_int (Production.to_int prod)
| Shift sym -> "Shift " ^ symbol_name sym
| Seq actions ->
"Seq ["
^ String.concat ~sep:"; " (List.map ~f:action_to_string actions)
^ "]"
(** The synthesizer specify the cost as a system of equations of the form $$
x_i = \min_\{j\} (\{\kappa_\{i,j\} + \sum_\{k\}x_\{i,j,k\}\}) $$ which can
be read as follow:
- $x_i$ are variables, the thing we would like to know the cost of (the
`Head` and `Tail` defined above)
- $j$ ranges over the different branches, the different candidates (for
instance, to synthesize a _non-terminal_, each production that reduces
to this _non-terminal_ is a valid candidate)
- each of these candidates is made of a constant and the sum of a possibly
empty list of other variables
Variables are valued in $\left[0,+\infin\right]$ (and the empty $\sum$
defaults to $0$, the empty $min$ to $+\infin$).
The solution is the least fixed point of this system computed by
[Fix](https://gitlab.inria.fr/fpottier/fix) library.
$$ \begin\{align\} \text\{head\}_\{st,nt\} = & \min \left\{
\begin\{array\}\{ll\} \text\{cost\}(\text\{empty-reductions\}(st,nt))\\
\text\{tail-reductions\}(st,nt) \end\{array\} \right. \\
\text\{empty-reductions\}(st,nt) = & \\ \text\{tail\}_\{st,prod,i\} = &
\end\{align\} $$
For a variable `Head (st, nt)` , the branches are the different
productions that can reduce to `nt` and starts from state `st`. The
constant is the same for all branches, $\kappa_\{i,j\} = \kappa_i$, *)
let const c _ = c
let cost_of_prod p = Cost.add (Cost.of_int 1) (A.cost_of_prod p)
let cost_of_symbol s = Cost.add (Cost.of_int 1) (A.cost_of_symbol s)
let penalty_of_item i = A.penalty_of_item i
let app var v = v var
let bottom = Cost.infinite, [ Abort ]
let var var =
match var with
| Head _ -> app var
| Tail (_, prod, pos) ->
let prod_len = Array.length (Production.rhs prod) in
assert (pos <= prod_len);
if pos < prod_len
then app var
else const (cost_of_prod prod, [ Reduce prod ])
let productions =
let table = Array.make Nonterminal.count [] in
Production.iter (fun p ->
let nt = Nonterminal.to_int (Production.lhs p) in
table.(nt) <- p :: table.(nt));
fun nt -> table.(Nonterminal.to_int nt)
let cost_of = function
| Head (st, nt) ->
fun v ->
let minimize_over_prod ((cost, _) as solution) prod =
let ((cost', _) as solution') = v (Tail (st, prod, 0)) in
if cost <= cost' then solution else solution'
in
List.fold_left (productions nt) ~init:bottom ~f:minimize_over_prod
| Tail (st, prod, pos) ->
let prod_len = Array.length (Production.rhs prod) in
assert (pos <= prod_len);
let penalty = penalty_of_item (prod, pos) in
if Cost.is_infinite penalty
then const bottom
else if pos = prod_len
then
let can_reduce =
List.exists
~f:(fun (_, prods) -> List.mem prod ~set:prods)
(Lr1.reductions st [@alert "-deprecated"])
in
const
(if can_reduce
then cost_of_prod prod, [ Reduce prod ]
else Cost.infinite, [ Abort ])
else
let head =
let sym, _, _ = (Production.rhs prod).(pos) in
let cost = cost_of_symbol sym in
if Cost.is_infinite cost
then match sym with T _ -> const bottom | N n -> var (Head (st, n))
else const (cost, [ Shift sym ])
in
let tail =
let sym, _, _ = (Production.rhs prod).(pos) in
match List.assoc sym (Lr1.transitions st) with
| st' -> var (Tail (st', prod, pos + 1))
| exception Not_found ->
(*report "no transition: #%d (%d,%d)\n" st.lr1_index prod.p_index
pos;*)
const bottom
in
fun v ->
let costh, actionh = head v in
let costt, actiont = tail v in
Cost.add costh costt, Seq actionh :: actiont
let solve =
(* For > 4.02 let module Solver = Fix.Fix.ForType (struct type t = variable
end) (struct type property = Cost.t * action list let bottom =
(Cost.infinite, [Abort]) let equal (x, _ : property) (y, _ : property) :
bool = Cost.compare x y = 0 let is_maximal _ = false end) in *)
let module Solver =
Fix.Make
(struct
type key = variable
type 'data t = (key, 'data) Hashtbl.t
let create () = Hashtbl.create 97
let clear tbl = Hashtbl.clear tbl
let add key value tbl = Hashtbl.add tbl key value
let find key tbl = Hashtbl.find tbl key
let iter f tbl = Hashtbl.iter f tbl
end)
(struct
type property = Cost.t * action list
let bottom = Cost.infinite, [ Abort ]
let equal ((x, _) : property) ((y, _) : property) : bool =
Cost.compare x y = 0
let is_maximal _ = false
end)
in
Solver.lfp cost_of
let report ppf =
let open Format in
let solutions =
Lr1.fold
(fun st acc ->
match
List.fold_left
(Lr0.items (Lr1.lr0 st))
~init:(None, bottom)
~f:(fun (item, ((cost, _) as solution)) (prod, pos) ->
let ((cost', _) as solution') = solve (Tail (st, prod, pos)) in
if cost' < cost
then Some (prod, pos), solution'
else item, solution)
with
| None, _ ->
fprintf ppf "no synthesis from %d\n" (Lr1.to_int st);
acc
| Some item, cost -> (item, (cost, st)) :: acc)
[]
in
let fprintf = Format.fprintf in
let rec print_action ppf = function
| Abort -> fprintf ppf "Abort"
| Reduce prod -> fprintf ppf "Reduce %d" (Production.to_int prod)
| Shift (T t) -> fprintf ppf "Shift (T %s)" (Terminal.name t)
| Shift (N n) -> fprintf ppf "Shift (N %s)" (Nonterminal.mangled_name n)
| Seq actions -> fprintf ppf "Seq %a" print_actions actions
and print_actions ppf = pp_list ~f:print_action ppf in
List.iter
~f:(fun (item, states) ->
fprintf ppf "# Item (%d,%d)\n" (Production.to_int (fst item)) (snd item);
Print.item ppf item;
List.iter
~f:(fun ((cost, actions), states) ->
fprintf
ppf
"at cost %a from states %a:\n%a\n\n"
Cost.pp
cost
(pp_list ~f:(fun ppf st -> fprintf ppf "#%d" (Lr1.to_int st)))
states
print_actions
actions)
(group_assoc states))
(group_assoc solutions)
end
================================================
FILE: src/menhir-recover/synthesis.mli
================================================
open MenhirSdk.Cmly_api
open Attributes
val group_assoc : ('a * 'b) list -> ('a * 'b list) list
val pp_list :
f:(Format.formatter -> 'a -> unit)
-> Format.formatter
-> 'a list
-> unit
(** Specification of synthesized tactics *)
module type SYNTHESIZER = sig
module G : GRAMMAR
(* Specification of problems
There are two situations we want to synthesize solution for:
- `Head` is when the dot is just in front of some non-terminal, and we
would like to find a way to move the dot to the right of this symbol (by
executing a sequence of actions that results in this non-terminal being
pushed on the stack)
- `Tail` is when the dot is in some production that we would like to
reduce. *)
type variable =
| Head of G.lr1 * G.nonterminal
| Tail of G.lr1 * G.production * int
(* The integer parameter in `Tail` is the position of the dot in the
production we are trying to reduce. This is necessary to uniquely identify
a production that occurs multiple time in a state.
For instance, in the grammar:
%token<int> INT %token PLUS
expr: | INT \{ $1 \} (*const*) | expr PLUS expr \{ $1 + $2 \} (*add*)
Synthesizing `Head (st0, expr)` when `expr PLUS . expr` is in `st0` will
output the actions to get to the state `st'` containing `expr PLUS expr .`.
Synthesizing `Tail (st1, add, 1)` when `expr . PLUS expr` is in `st1` will
output the actions that end up reducing `add` (which will likely be
shifting `PLUS`, synthesizing `Head (st0, expr)` and reducing add). *)
val variable_to_string : variable -> string
(** A human readable representation of a [variable]. *)
(** Specification of solutions
A successful synthesis results in a list of actions. *)
type action =
| Abort
| Reduce of G.production
| Shift of G.symbol
| Seq of action list
(* `Abort` is issued if there is no solution. This is the case for instance if
there is a semantic value that the synthesizer cannot produce, or a
production with an infinite cost.
`Shift` and `Reduce` are direct actions to execute on the parser.
`Seq` is a sequence of action. *)
val action_to_string : action -> string
(** A human readable representation of an action. *)
val solve : variable -> Cost.t * action list
(** Give the solution found for a variable as a list of action. *)
val report : Format.formatter -> unit
(** Print the solutions or absence thereof for the whole grammar. *)
end
(** Synthesizer implementation *)
module Synthesizer (G : GRAMMAR) (_ : ATTRIBUTES with module G = G) :
SYNTHESIZER with module G := G
================================================
FILE: src/reason-merlin/dune
================================================
(executable
(name ocamlmerlin_reason)
(public_name ocamlmerlin-reason)
(package reason)
(flags :standard -open StdLabels)
(libraries compiler-libs.common merlin-extend reason))
================================================
FILE: src/reason-merlin/ocamlmerlin_reason.ml
================================================
open Reason
let () = Reason_config.recoverable := true
module Reason_reader = struct
open Extend_protocol.Reader
type t = buffer
let load buffer = buffer
let structure str =
let str =
str
|> Reason_syntax_util.(
apply_mapper_to_structure remove_stylistic_attrs_mapper)
|> Reason_syntax_util.(apply_mapper_to_structure backport_letopt_mapper)
in
Structure (Reason_toolchain.To_current.copy_structure str)
let signature sg =
let sg =
let open Reason_syntax_util in
sg
|> apply_mapper_to_signature remove_stylistic_attrs_mapper
|> apply_mapper_to_signature backport_letopt_mapper
in
Signature (Reason_toolchain.To_current.copy_signature sg)
let parse { text; path; _ } =
let buf = Lexing.from_string text in
Location.init buf (Filename.basename path);
let l = String.length path in
if l > 0 && String.unsafe_get path (l - 1) = 'i'
then signature (Reason_toolchain.RE.interface buf)
else structure (Reason_toolchain.RE.implementation buf)
let for_completion t pos =
let pos' = !Reason_toolchain_conf.insert_completion_ident in
Reason_toolchain_conf.insert_completion_ident := Some pos;
Misc.try_finally
(fun () -> { complete_labels = true }, parse t)
~always:(fun () -> Reason_toolchain_conf.insert_completion_ident := pos')
let parse_line _ _ line =
let buf = Lexing.from_string line in
structure (Reason_toolchain.RE.implementation buf)
let ident_at _ _ = []
let formatter =
let fmt = lazy (Reason_pprint_ast.createFormatter ()) in
fun () -> Lazy.force fmt
let pretty_print =
let module From_current = Reason_toolchain.From_current in
fun ppf ppt ->
let fmt = formatter () in
match ppt with
| Pretty_core_type x -> fmt#core_type ppf (From_current.copy_core_type x)
| Pretty_case_list x ->
fmt#case_list ppf (List.map ~f:From_current.copy_case x)
| Pretty_expression x ->
fmt#expression ppf (From_current.copy_expression x)
| Pretty_pattern x -> fmt#pattern ppf (From_current.copy_pattern x)
| Pretty_signature x ->
fmt#signature [] ppf (From_current.copy_signature x)
| Pretty_structure x ->
fmt#structure [] ppf (From_current.copy_structure x)
| Pretty_toplevel_phrase x ->
fmt#toplevel_phrase ppf (From_current.copy_toplevel_phrase x)
let print_outcome =
let module From_current = Reason_toolchain.From_current in
fun ppf otree ->
match otree with
| Out_value x ->
Reason_oprint.print_out_value ppf (From_current.copy_out_value x)
| Out_type x ->
Reason_oprint.print_out_type ppf (From_current.copy_out_type x)
| Out_class_type x ->
Reason_oprint.print_out_class_type
ppf
(From_current.copy_out_class_type x)
| Out_module_type x ->
Reason_oprint.print_out_module_type
ppf
(From_current.copy_out_module_type x)
| Out_sig_item x ->
Reason_oprint.print_out_sig_item ppf (From_current.copy_out_sig_item x)
| Out_signature x ->
Reason_oprint.print_out_signature
ppf
(List.map ~f:From_current.copy_out_sig_item x)
| Out_type_extension x ->
Reason_oprint.print_out_type_extension
ppf
(From_current.copy_out_type_extension x)
| Out_phrase x ->
Reason_oprint.print_out_phrase ppf (From_current.copy_out_phrase x)
end
let () =
if Sys.win32
then (
set_binary_mode_in stdin true;
set_binary_mode_out stdout true);
Extend_main.extension_main
~reader:
(Extend_main.Reader.make_v0
(module Reason_reader : Extend_protocol.Reader.V0))
(Extend_main.Description.make_v0 ~name:"reason" ~version:"0.1")
================================================
FILE: src/reason-parser/TODO
================================================
Recovery (Urgent):
* Not clear what the pipeline for errors should be
* Find better names for the many modules
* If necessary, tune performance
* What is the licensing situation?
Error messages (Medium-term):
* Agree on a strategy with other people: what should messages look like?
What should they do: describe the context? suggest common corrections?
Point people to grammar documentation?
* To learn what correct files look like we can probably data-mine public reason
repositories.
* To learn what incorrect files look like, we need some way to collect common
errors!!!!
Completion (Long-term):
* Introduce merlin.location when there is ambiguity between concrete and
abstract locations
================================================
FILE: src/reason-parser/dune
================================================
(ocamllex
(modules reason_declarative_lexer))
(rule
(targets ocaml_util.ml)
(deps ocaml_util.cppo.ml)
(action
(run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets})))
(rule
(targets ocaml_util.mli)
(deps ocaml_util.cppo.mli)
(action
(run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets})))
(menhir
(flags --strict --inspection --unused-tokens --table --cmly)
(modules reason_parser))
; Previously, make preprocess.
; (rule
; (targets reason_parser.cmly reason_parser.ml reason_parser.mli)
; (deps reason_parser.mly)
; (action
; (run menhir --strict --inspection --infer
; --unused-tokens
; --fixed-exception
; --table
; --cmly reason_parser.mly)))
(rule
(targets reason_parser_explain_raw.ml)
(deps reason_parser.cmly)
(action
(with-stdout-to
%{targets}
(run
../menhir-error-processor/menhir_error_processor.exe
reason_parser.cmly))))
(rule
(targets reason_parser_recover.ml)
(deps reason_parser.cmly)
(action
(with-stdout-to
%{targets}
(run ../menhir-recover/menhir_recover.exe reason_parser.cmly))))
(library
(name reason)
; Uncomment to allow make coverage target to work
; requires you to have run $ opam install bisect_ppx
; (preprocess (pps (bisect_ppx)))
(public_name reason)
(flags :standard -open StdLabels)
(libraries
reason.ocaml-migrate-parsetree
menhirLib
reason.easy_format
ppxlib))
================================================
FILE: src/reason-parser/error-handling.md
================================================
Categories of error:
- Lexer errors, produced by `Reason_lexer` and stored in exception
`Reason_lexer.Error`
- Concrete parsing errors, produced by menhir code when
================================================
FILE: src/reason-parser/merlin_recovery.ml
================================================
let split_pos { Lexing.pos_lnum; pos_bol; pos_cnum; _ } =
pos_lnum, pos_cnum - pos_bol
let rev_filter ~f xs =
let rec aux f acc = function
| x :: xs when f x -> aux f (x :: acc) xs
| _ :: xs -> aux f acc xs
| [] -> acc
in
aux f [] xs
let rec rev_scan_left acc ~f ~init = function
| [] -> acc
| x :: xs ->
let init = f init x in
rev_scan_left (init :: acc) ~f ~init xs
module Make
(Parser : MenhirLib.IncrementalEngine.EVERYTHING)
(Recovery : Merlin_recovery_intf.RECOVERY with module Parser := Parser) =
struct
type 'a candidate =
{ line : int
; min_col : int
; max_col : int
; env : 'a Parser.env
}
type 'a candidates =
{ shifted : Parser.xsymbol option
; final : 'a option
; candidates : 'a candidate list
}
module T = struct
[@@@ocaml.warning "-37"]
type 'a checkpoint =
| InputNeeded of 'a Parser.env
| Shifting of 'a Parser.env * 'a Parser.env * bool
| AboutToReduce of 'a Parser.env * Parser.production
| HandlingError of 'a Parser.env
| Accepted of 'a
| Rejected
external inj : 'a checkpoint -> 'a Parser.checkpoint = "%identity"
end
let feed_token ~allow_reduction token env =
let rec aux allow_reduction = function
| Parser.HandlingError _ | Parser.Rejected -> `Fail
| Parser.AboutToReduce _ when not allow_reduction -> `Fail
| Parser.Accepted v -> `Accept v
| (Parser.Shifting _ | Parser.AboutToReduce _) as checkpoint ->
aux true (Parser.resume checkpoint)
| Parser.InputNeeded env as checkpoint -> `Recovered (checkpoint, env)
in
aux allow_reduction (Parser.offer (T.inj (T.InputNeeded env)) token)
let rec follow_guide col env =
match Parser.top env with
| None -> col
| Some (Parser.Element (state, _, pos, _)) ->
if Recovery.guide (Parser.incoming_symbol state)
then
match Parser.pop env with
| None -> col
| Some env -> follow_guide (snd (split_pos pos)) env
else col
let candidate env =
let line, min_col, max_col =
match Parser.top env with
| None -> 1, 0, 0
| Some (Parser.Element (state, _, pos, _)) ->
let depth = Recovery.depth.(Parser.number state) in
let line, col = split_pos pos in
if depth = 0
then line, col, col
else
let col' =
match Parser.pop_many depth env with
| None -> max_int
| Some env ->
(match Parser.top env with
| None -> max_int
| Some (Parser.Element (_, _, pos, _)) ->
follow_guide (snd (split_pos pos)) env)
in
line, min col col', max col col'
in
{ line; min_col; max_col; env }
let attempt r token =
let _, startp, _ = token in
let line, col = split_pos startp in
let more_indented candidate =
line <> candidate.line && candidate.min_col > col
in
let recoveries =
let rec aux = function
| x :: xs when more_indented x -> aux xs
| xs -> xs
in
aux r.candidates
in
let same_indented candidate =
line = candidate.line
|| (candidate.min_col <= col && col <= candidate.max_col)
in
let recoveries =
let rec aux = function
| x :: xs when same_indented x -> x :: aux xs
| _ -> []
in
aux recoveries
in
let rec aux = function
| [] -> `Fail
| x :: xs ->
(match feed_token ~allow_reduction:true token x.env with
| `Fail -> aux xs
| `Recovered (checkpoint, _) -> `Ok (checkpoint, x.env)
| `Accept v -> (match aux xs with `Fail -> `Accept v | x -> x))
in
aux recoveries
let decide env =
let rec nth_state env n =
if n = 0
then
match Parser.top env with
| None -> -1 (*allow giving up recovery on empty files*)
| Some (Parser.Element (state, _, _, _)) -> Parser.number state
else
match Parser.pop env with
| None ->
assert (n = 1);
-1
| Some env -> nth_state env (n - 1)
in
let st = nth_state env 0 in
match Recovery.recover st with
| Recovery.Nothing -> []
| Recovery.One actions -> actions
| Recovery.Select f -> f (nth_state env Recovery.depth.(st))
let generate (type a) (env : a Parser.env) =
let module E = struct
exception Result of a
end
in
let shifted = ref None in
let rec aux acc env =
match Parser.top env with
| None -> None, acc
| Some (Parser.Element (_state, _, _startp, endp)) ->
let actions = decide env in
let candidate0 = candidate env in
let rec eval (env : a Parser.env) : Recovery.action -> a Parser.env
= function
| Recovery.Abort -> raise Not_found
| Recovery.R prod ->
let prod = Parser.find_production prod in
Parser.force_reduction prod env
| Recovery.S (Parser.N n as sym) ->
let xsym = Parser.X sym in
if !shifted = None && not (Recovery.nullable n)
then shifted := Some xsym;
let loc =
{ Location.loc_start = endp; loc_end = endp; loc_ghost = true }
in
let v = Recovery.default_value loc sym in
Parser.feed sym endp v endp env
| Recovery.S (Parser.T t as sym) ->
let xsym = Parser.X sym in
if !shifted = None then shifted := Some xsym;
let loc =
{ Location.loc_start = endp; loc_end = endp; loc_ghost = true }
in
let v = Recovery.default_value loc sym in
let token = Recovery.token_of_terminal t v, endp, endp in
(match feed_token ~allow_reduction:true token env with
| `Fail -> assert false
| `Accept v -> raise (E.Result v)
| `Recovered (_, env) -> env)
| Recovery.Sub actions -> List.fold_left ~f:eval ~init:env actions
in
(match
rev_scan_left [] ~f:eval ~init:env actions
|> List.map ~f:(fun env -> { candidate0 with env })
with
| exception Not_found -> None, acc
| exception E.Result v -> Some v, acc
| [] -> None, acc
| candidate :: _ as candidates -> aux (candidates @ acc) candidate.env)
in
let final, candidates = aux [] env in
!shifted, final, candidates
let generate env =
let shifted, final, candidates = generate env in
let candidates =
rev_filter candidates ~f:(fun t ->
not (Parser.env_has_default_reduction t.env))
in
{ shifted; final; candidates = candidate env :: candidates }
end
================================================
FILE: src/reason-parser/merlin_recovery.mli
================================================
module Make
(Parser : MenhirLib.IncrementalEngine.EVERYTHING)
(_ : Merlin_recovery_intf.RECOVERY with module Parser := Parser) : sig
type 'a candidate =
{ line : int
; min_col : int
; max_col : int
; env : 'a Parser.env
}
type 'a candidates =
{ shifted : Parser.xsymbol option
; final : 'a option
; candidates : 'a candidate list
}
val attempt :
'a candidates
-> Parser.token * Lexing.position * Lexing.position
-> [> `Accept of 'a | `Fail | `Ok of 'a Parser.checkpoint * 'a Parser.env ]
val generate : 'a Parser.env -> 'a candidates
end
================================================
FILE: src/reason-parser/merlin_recovery_intf.ml
================================================
module type RECOVERY = sig
module Parser : MenhirLib.IncrementalEngine.EVERYTHING
val default_value : Location.t -> 'a Parser.symbol -> 'a
type action =
| Abort
| R of int
| S : 'a Parser.symbol -> action
| Sub of action list
type decision =
| Nothing
| One of action list
| Select of (int -> action list)
val depth : int array
val recover : int -> decision
val guide : 'a Parser.symbol -> bool
val token_of_terminal : 'a Parser.terminal -> 'a -> Parser.token
val nullable : 'a Parser.nonterminal -> bool
end
================================================
FILE: src/reason-parser/ocaml_util.cppo.ml
================================================
let print_error ~loc ~f ppf x =
#if OCAML_VERSION >= (5,3,0)
let error =
let f = Format_doc.deprecated f in
Location.error_of_printer ~loc f x in
Location.print_report ppf error
#elif OCAML_VERSION >= (4,8,0)
let error = Location.error_of_printer ~loc f x in
Location.print_report ppf error
#else
let error = Location.error_of_printer loc f x in
Location.report_error ppf error
#endif
#if OCAML_VERSION < (4,14,0)
module Uchar = struct
include Uchar
let valid_bit = 27
let decode_bits = 24
let[@inline] utf_decode_is_valid d = (d lsr valid_bit) = 1
let[@inline] utf_decode_length d = (d lsr decode_bits) land 0b111
let[@inline] utf_decode_uchar d = unsafe_of_int (d land 0xFFFFFF)
let[@inline] utf_decode n u = ((8 lor n) lsl decode_bits) lor (to_int u)
let rep = 0xFFFD
let[@inline] utf_decode_invalid n = (n lsl decode_bits) lor rep
let rep = Uchar.rep
end
module Bytes = struct
include Bytes
external unsafe_get_uint8 : bytes -> int -> int = "%bytes_unsafe_get"
external get_uint8 : bytes -> int -> int = "%bytes_safe_get"
external unsafe_set_uint8 : bytes -> int -> int -> unit = "%bytes_unsafe_set"
external set_int8 : bytes -> int -> int -> unit = "%bytes_safe_set"
let get_int8 b i =
((get_uint8 b i) lsl (Sys.int_size - 8)) asr (Sys.int_size - 8)
let set_uint8 = set_int8
(* UTF codecs and validations *)
let dec_invalid = Uchar.utf_decode_invalid
let[@inline] dec_ret n u = Uchar.utf_decode n (Uchar.unsafe_of_int u)
let[@inline] not_in_x80_to_xBF b = b lsr 6 <> 0b10
let[@inline] not_in_xA0_to_xBF b = b lsr 5 <> 0b101
let[@inline] not_in_x80_to_x9F b = b lsr 5 <> 0b100
let[@inline] not_in_x90_to_xBF b = b < 0x90 || 0xBF < b
let[@inline] not_in_x80_to_x8F b = b lsr 4 <> 0x8
let[@inline] utf_8_uchar_2 b0 b1 =
((b0 land 0x1F) lsl 6) lor
((b1 land 0x3F))
let[@inline] utf_8_uchar_3 b0 b1 b2 =
((b0 land 0x0F) lsl 12) lor
((b1 land 0x3F) lsl 6) lor
((b2 land 0x3F))
let[@inline] utf_8_uchar_4 b0 b1 b2 b3 =
((b0 land 0x07) lsl 18) lor
((b1 land 0x3F) lsl 12) lor
((b2 land 0x3F) lsl 6) lor
((b3 land 0x3F))
let get_utf_8_uchar b i =
let b0 = get_uint8 b i in (* raises if [i] is not a valid index. *)
let get = unsafe_get_uint8 in
let max = length b - 1 in
match Char.unsafe_chr b0 with (* See The Unicode Standard, Table 3.7 *)
| '\x00' .. '\x7F' -> dec_ret 1 b0
| '\xC2' .. '\xDF' ->
let i = i + 1 in if i > max then dec_invalid 1 else
let b1 = get b i in if not_in_x80_to_xBF b1 then dec_invalid 1 else
dec_ret 2 (utf_8_uchar_2 b0 b1)
| '\xE0' ->
let i = i + 1 in if i > max then dec_invalid 1 else
let b1 = get b i in if not_in_xA0_to_xBF b1 then dec_invalid 1 else
let i = i + 1 in if i > max then dec_invalid 2 else
let b2 = get b i in if not_in_x80_to_xBF b2 then dec_invalid 2 else
dec_ret 3 (utf_8_uchar_3 b0 b1 b2)
| '\xE1' .. '\xEC' | '\xEE' .. '\xEF' ->
let i = i + 1 in if i > max then dec_invalid 1 else
let b1 = get b i in if not_in_x80_to_xBF b1 then dec_invalid 1 else
let i = i + 1 in if i > max then dec_invalid 2 else
let b2 = get b i in if not_in_x80_to_xBF b2 then dec_invalid 2 else
dec_ret 3 (utf_8_uchar_3 b0 b1 b2)
| '\xED' ->
let i = i + 1 in if i > max then dec_invalid 1 else
let b1 = get b i in if not_in_x80_to_x9F b1 then dec_invalid 1 else
let i = i + 1 in if i > max then dec_invalid 2 else
let b2 = get b i in if not_in_x80_to_xBF b2 then dec_invalid 2 else
dec_ret 3 (utf_8_uchar_3 b0 b1 b2)
| '\xF0' ->
let i = i + 1 in if i > max then dec_invalid 1 else
let b1 = get b i in if not_in_x90_to_xBF b1 then dec_invalid 1 else
let i = i + 1 in if i > max then dec_invalid 2 else
let b2 = get b i in if not_in_x80_to_xBF b2 then dec_invalid 2 else
let i = i + 1 in if i > max then dec_invalid 3 else
let b3 = get b i in if not_in_x80_to_xBF b3 then dec_invalid 3 else
dec_ret 4 (utf_8_uchar_4 b0 b1 b2 b3)
| '\xF1' .. '\xF3' ->
let i = i + 1 in if i > max then dec_invalid 1 else
let b1 = get b i in if not_in_x80_to_xBF b1 then dec_invalid 1 else
let i = i + 1 in if i > max then dec_invalid 2 else
let b2 = get b i in if not_in_x80_to_xBF b2 then dec_invalid 2 else
let i = i + 1 in if i > max then dec_invalid 3 else
let b3 = get b i in if not_in_x80_to_xBF b3 then dec_invalid 3 else
dec_ret 4 (utf_8_uchar_4 b0 b1 b2 b3)
| '\xF4' ->
let i = i + 1 in if i > max then dec_invalid 1 else
let b1 = get b i in if not_in_x80_to_x8F b1 then dec_invalid 1 else
let i = i + 1 in if i > max then dec_invalid 2 else
let b2 = get b i in if not_in_x80_to_xBF b2 then dec_invalid 2 else
let i = i + 1 in if i > max then dec_invalid 3 else
let b3 = get b i in if not_in_x80_to_xBF b3 then dec_invalid 3 else
dec_ret 4 (utf_8_uchar_4 b0 b1 b2 b3)
| _ -> dec_invalid 1
let set_utf_8_uchar b i u =
let set = unsafe_set_uint8 in
let max = length b - 1 in
match Uchar.to_int u with
| u when u < 0 -> assert false
| u when u <= 0x007F ->
set_uint8 b i u;
1
| u when u <= 0x07FF ->
let last = i + 1 in
if last > max then 0 else
(set_uint8 b i (0xC0 lor (u lsr 6));
set b last (0x80 lor (u land 0x3F));
2)
| u when u <= 0xFFFF ->
let last = i + 2 in
if last > max then 0 else
(set_uint8 b i (0xE0 lor (u lsr 12));
set b (i + 1) (0x80 lor ((u lsr 6) land 0x3F));
set b last (0x80 lor (u land 0x3F));
3)
| u when u <= 0x10FFFF ->
let last = i + 3 in
if last > max then 0 else
(set_uint8 b i (0xF0 lor (u lsr 18));
set b (i + 1) (0x80 lor ((u lsr 12) land 0x3F));
set b (i + 2) (0x80 lor ((u lsr 6) land 0x3F));
set b last (0x80 lor (u land 0x3F));
4)
| _ -> assert false
let is_valid_utf_8 b =
let rec loop max b i =
if i > max then true else
let get = unsafe_get_uint8 in
match Char.unsafe_chr (get b i) with
| '\x00' .. '\x7F' -> loop max b (i + 1)
| '\xC2' .. '\xDF' ->
let last = i + 1 in
if last > max
|| not_in_x80_to_xBF (get b last)
then false
else loop max b (last + 1)
| '\xE0' ->
let last = i + 2 in
if last > max
|| not_in_xA0_to_xBF (get b (i + 1))
|| not_in_x80_to_xBF (get b last)
then false
else loop max b (last + 1)
| '\xE1' .. '\xEC' | '\xEE' .. '\xEF' ->
let last = i + 2 in
if last > max
|| not_in_x80_to_xBF (get b (i + 1))
|| not_in_x80_to_xBF (get b last)
then false
else loop max b (last + 1)
| '\xED' ->
let last = i + 2 in
if last > max
|| not_in_x80_to_x9F (get b (i + 1))
|| not_in_x80_to_xBF (get b last)
then false
else loop max b (last + 1)
| '\xF0' ->
let last = i + 3 in
if last > max
|| not_in_x90_to_xBF (get b (i + 1))
|| not_in_x80_to_xBF (get b (i + 2))
|| not_in_x80_to_xBF (get b last)
then false
else loop max b (last + 1)
| '\xF1' .. '\xF3' ->
let last = i + 3 in
if last > max
|| not_in_x80_to_xBF (get b (i + 1))
|| not_in_x80_to_xBF (get b (i + 2))
|| not_in_x80_to_xBF (get b last)
then false
else loop max b (last + 1)
| '\xF4' ->
let last = i + 3 in
if last > max
|| not_in_x80_to_x8F (get b (i + 1))
|| not_in_x80_to_xBF (get b (i + 2))
|| not_in_x80_to_xBF (get b last)
then false
else loop max b (last + 1)
| _ -> false
in
loop (length b - 1) b 0
end
module String = struct
include String
module B = struct
include Bytes
let for_all ~f:p s =
let n = length s in
let rec loop i =
if i = n then true
else if p (unsafe_get s i) then loop (succ i)
else false in
loop 0
end
let bos = B.unsafe_of_string
let for_all ~f s =
B.for_all ~f (bos s)
let get_utf_8_uchar s i = B.get_utf_8_uchar (bos s) i
let is_valid_utf_8 s = B.is_valid_utf_8 (bos s)
(** {6 Binary encoding/decoding of integers} *)
external get_uint8 : string -> int -> int = "%string_safe_get"
external get_uint16_ne : string -> int -> int = "%caml_string_get16"
external get_int32_ne : string -> int -> int32 = "%caml_string_get32"
external get_int64_ne : string -> int -> int64 = "%caml_string_get64"
let get_int8 s i = B.get_int8 (bos s) i
end
#endif
#if OCAML_VERSION >= (5,3,0)
module Utf8_lexeme = Misc.Utf8_lexeme
#else
(** {1 Minimal support for Unicode characters in identifiers} *)
module Utf8_lexeme = struct
type t = string
(* Non-ASCII letters that are allowed in identifiers (currently: Latin-9) *)
type case = Upper of Uchar.t | Lower of Uchar.t
let known_chars : (Uchar.t, case) Hashtbl.t = Hashtbl.create 32
let _ =
List.iter
~f:(fun (upper, lower) ->
let upper = Uchar.of_int upper and lower = Uchar.of_int lower in
Hashtbl.add known_chars upper (Upper lower);
Hashtbl.add known_chars lower (Lower upper))
[
(0xc0, 0xe0); (* À, à *) (0xc1, 0xe1); (* Á, á *)
(0xc2, 0xe2); (* Â, â *) (0xc3, 0xe3); (* Ã, ã *)
(0xc4, 0xe4); (* Ä, ä *) (0xc5, 0xe5); (* Å, å *)
(0xc6, 0xe6); (* Æ, æ *) (0xc7, 0xe7); (* Ç, ç *)
(0xc8, 0xe8); (* È, è *) (0xc9, 0xe9); (* É, é *)
(0xca, 0xea); (* Ê, ê *) (0xcb, 0xeb); (* Ë, ë *)
(0xcc, 0xec); (* Ì, ì *) (0xcd, 0xed); (* Í, í *)
(0xce, 0xee); (* Î, î *) (0xcf, 0xef); (* Ï, ï *)
(0xd0, 0xf0); (* Ð, ð *) (0xd1, 0xf1); (* Ñ, ñ *)
(0xd2, 0xf2); (* Ò, ò *) (0xd3, 0xf3); (* Ó, ó *)
(0xd4, 0xf4); (* Ô, ô *) (0xd5, 0xf5); (* Õ, õ *)
(0xd6, 0xf6); (* Ö, ö *) (0xd8, 0xf8); (* Ø, ø *)
(0xd9, 0xf9); (* Ù, ù *) (0xda, 0xfa); (* Ú, ú *)
(0xdb, 0xfb); (* Û, û *) (0xdc, 0xfc); (* Ü, ü *)
(0xdd, 0xfd); (* Ý, ý *) (0xde, 0xfe); (* Þ, þ *)
(0x160, 0x161); (* Š, š *) (0x17d, 0x17e); (* Ž, ž *)
(0x152, 0x153); (* Œ, œ *) (0x178, 0xff); (* Ÿ, ÿ *)
(0x1e9e, 0xdf); (* ẞ, ß *)
]
(* NFD to NFC conversion table for the letters above *)
let known_pairs : (Uchar.t * Uchar.t, Uchar.t) Hashtbl.t = Hashtbl.create 32
let _ =
List.iter
~f:(fun (c1, n2, n) ->
Hashtbl.add known_pairs
(Uchar.of_char c1, Uchar.of_int n2) (Uchar.of_int n))
[
('A', 0x300, 0xc0); (* À *) ('A', 0x301, 0xc1); (* Á *)
('A', 0x302, 0xc2); (* Â *) ('A', 0x303, 0xc3); (* Ã *)
('A', 0x308, 0xc4); (* Ä *) ('A', 0x30a, 0xc5); (* Å *)
('C', 0x327, 0xc7); (* Ç *) ('E', 0x300, 0xc8); (* È *)
('E', 0x301, 0xc9); (* É *) ('E', 0x302, 0xca); (* Ê *)
('E', 0x308, 0xcb); (* Ë *) ('I', 0x300, 0xcc); (* Ì *)
('I', 0x301, 0xcd); (* Í *) ('I', 0x302, 0xce); (* Î *)
('I', 0x308, 0xcf); (* Ï *) ('N', 0x303, 0xd1); (* Ñ *)
('O', 0x300, 0xd2); (* Ò *) ('O', 0x301, 0xd3); (* Ó *)
('O', 0x302, 0xd4); (* Ô *) ('O', 0x303, 0xd5); (* Õ *)
('O', 0x308, 0xd6); (* Ö *)
('U', 0x300, 0xd9); (* Ù *) ('U', 0x301, 0xda); (* Ú *)
('U', 0x302, 0xdb); (* Û *) ('U', 0x308, 0xdc); (* Ü *)
('Y', 0x301, 0xdd); (* Ý *) ('Y', 0x308, 0x178); (* Ÿ *)
('S', 0x30c, 0x160); (* Š *) ('Z', 0x30c, 0x17d); (* Ž *)
('a', 0x300, 0xe0); (* à *) ('a', 0x301, 0xe1); (* á *)
('a', 0x302, 0xe2); (* â *) ('a', 0x303, 0xe3); (* ã *)
('a', 0x308, 0xe4); (* ä *) ('a', 0x30a, 0xe5); (* å *)
('c', 0x327, 0xe7); (* ç *) ('e', 0x300, 0xe8); (* è *)
('e', 0x301, 0xe9); (* é *) ('e', 0x302, 0xea); (* ê *)
('e', 0x308, 0xeb); (* ë *) ('i', 0x300, 0xec); (* ì *)
('i', 0x301, 0xed); (* í *) ('i', 0x302, 0xee); (* î *)
('i', 0x308, 0xef); (* ï *) ('n', 0x303, 0xf1); (* ñ *)
('o', 0x300, 0xf2); (* ò *) ('o', 0x301, 0xf3); (* ó *)
('o', 0x302, 0xf4); (* ô *) ('o', 0x303, 0xf5); (* õ *)
('o', 0x308, 0xf6); (* ö *)
('u', 0x300, 0xf9); (* ù *) ('u', 0x301, 0xfa); (* ú *)
('u', 0x302, 0xfb); (* û *) ('u', 0x308, 0xfc); (* ü *)
('y', 0x301, 0xfd); (* ý *) ('y', 0x308, 0xff); (* ÿ *)
('s', 0x30c, 0x161); (* š *) ('z', 0x30c, 0x17e); (* ž *)
]
let normalize_generic ~keep_ascii transform s =
let rec norm check buf prev i =
if i >= String.length s then begin
Buffer.add_utf_8_uchar buf (transform prev)
end else begin
let d = String.get_utf_8_uchar s i in
let u = Uchar.utf_decode_uchar d in
check d u;
let i' = i + Uchar.utf_decode_length d in
match Hashtbl.find_opt known_pairs (prev, u) with
| Some u' ->
norm check buf u' i'
| None ->
Buffer.add_utf_8_uchar buf (transform prev);
norm check buf u i'
end in
let ascii_limit = 128 in
if s = ""
|| keep_ascii && String.for_all ~f:(fun x -> Char.code x < ascii_limit) s
then Ok s
else
let buf = Buffer.create (String.length s) in
let valid = ref true in
let check d u =
valid := !valid && Uchar.utf_decode_is_valid d && u <> Uchar.rep
in
let d = String.get_utf_8_uchar s 0 in
let u = Uchar.utf_decode_uchar d in
check d u;
norm check buf u (Uchar.utf_decode_length d);
let contents = Buffer.contents buf in
if !valid then
Ok contents
else
Error contents
let normalize s =
normalize_generic ~keep_ascii:true (fun u -> u) s
(* Capitalization *)
let uchar_is_uppercase u =
let c = Uchar.to_int u in
if c < 0x80 then c >= 65 && c <= 90 else
match Hashtbl.find_opt known_chars u with
| Some(Upper _) -> true
| _ -> false
let is_capitalized s =
s <> "" &&
uchar_is_uppercase (Uchar.utf_decode_uchar (String.get_utf_8_uchar s 0))
(* Characters allowed in identifiers after normalization is applied.
Currently:
- ASCII letters, underscore
- Latin-9 letters, represented in NFC
- ASCII digits, single quote (but not as first character)
- dot if [with_dot] = true
*)
let uchar_valid_in_identifier ~with_dot u =
let c = Uchar.to_int u in
if c < 0x80 then
c >= 97 (* a *) && c <= 122 (* z *)
|| c >= 65 (* A *) && c <= 90 (* Z *)
|| c >= 48 (* 0 *) && c <= 57 (* 9 *)
|| c = 95 (* underscore *)
|| c = 39 (* single quote *)
|| (with_dot && c = 46) (* dot *)
else
Hashtbl.mem known_chars u
let uchar_not_identifier_start u =
let c = Uchar.to_int u in
c >= 48 (* 0 *) && c <= 57 (* 9 *)
|| c = 39 (* single quote *)
(* Check whether a normalized string is a valid OCaml identifier. *)
type validation_result =
| Valid
| Invalid_character of Uchar.t (** Character not allowed *)
| Invalid_beginning of Uchar.t (** Character not allowed as first char *)
let validate_identifier ?(with_dot=false) s =
let rec check i =
if i >= String.length s then Valid else begin
let d = String.get_utf_8_uchar s i in
let u = Uchar.utf_decode_uchar d in
let i' = i + Uchar.utf_decode_length d in
if not (uchar_valid_in_identifier ~with_dot u) then
Invalid_character u
else if i = 0 && uchar_not_identifier_start u then
Invalid_beginning u
else
check i'
end
in check 0
let is_valid_identifier s =
validate_identifier s = Valid
let is_lowercase s =
let rec is_lowercase_at len s n =
if n >= len then true
else
let d = String.get_utf_8_uchar s n in
let u = Uchar.utf_decode_uchar d in
(uchar_valid_in_identifier ~with_dot:false u)
&& not (uchar_is_uppercase u)
&& is_lowercase_at len s (n+Uchar.utf_decode_length d)
in
is_lowercase_at (String.length s) s 0
end
#endif
================================================
FILE: src/reason-parser/ocaml_util.cppo.mli
================================================
val print_error :
loc:Location.t
-> f:(Format.formatter -> 'a -> unit)
-> Format.formatter
-> 'a
-> unit
#if OCAML_VERSION >= (5,3,0)
module Utf8_lexeme = Misc.Utf8_lexeme
#else
module Utf8_lexeme : sig
type t = string
val normalize : t -> (t, string) result
val is_capitalized : t -> bool
type validation_result =
| Valid
| Invalid_character of Uchar.t (** Character not allowed *)
| Invalid_beginning of Uchar.t (** Character not allowed as first char *)
val validate_identifier : ?with_dot:bool -> t -> validation_result
val is_valid_identifier : t -> bool
val is_lowercase : t -> bool
end
#endif
================================================
FILE: src/reason-parser/reason_attributes.ml
================================================
open Ppxlib
type attributesPartition =
{ arityAttrs : attributes
; docAttrs : attributes
; stdAttrs : attributes
; jsxAttrs : attributes
; stylisticAttrs : attributes
; uncurried : bool
}
(** Kinds of attributes *)
(** Partition attributes into kinds *)
let rec partitionAttributes ?(partDoc = false) ?(allowUncurry = true) attrs :
attributesPartition
=
match attrs with
| [] ->
{ arityAttrs = []
; docAttrs = []
; stdAttrs = []
; jsxAttrs = []
; stylisticAttrs = []
; uncurried = false
}
| ({ attr_name = { txt = "u" | "bs"; _ }; attr_payload = PStr []; _ } as attr)
:: atTl ->
let partition = partitionAttributes ~partDoc ~allowUncurry atTl in
if allowUncurry
then { partition with uncurried = true }
else { partition with stdAttrs = attr :: partition.stdAttrs }
| ({ attr_name = { txt = "JSX"; _ }; _ } as jsx) :: atTl ->
let partition = partitionAttributes ~partDoc ~allowUncurry atTl in
{ partition with jsxAttrs = jsx :: partition.jsxAttrs }
| ({ attr_name = { txt = "explicit_arity"; _ }; _ } as arity_attr) :: atTl
| ({ attr_name = { txt = "implicit_arity"; _ }; _ } as arity_attr) :: atTl ->
let partition = partitionAttributes ~partDoc ~allowUncurry atTl in
{ partition with arityAttrs = arity_attr :: partition.arityAttrs }
| ({ attr_name = { txt = "ocaml.text"; _ }; _ } as doc) :: atTl
when partDoc = true ->
let partition = partitionAttributes ~partDoc ~allowUncurry atTl in
{ partition with docAttrs = doc :: partition.docAttrs }
| ({ attr_name = { txt = "ocaml.doc" | "ocaml.text"; _ }; _ } as doc) :: atTl
when partDoc = true ->
let partition = partitionAttributes ~partDoc ~allowUncurry atTl in
{ partition with docAttrs = doc :: partition.docAttrs }
| ({ attr_name = { txt = "reason.raw_literal"; _ }; _ } as attr) :: atTl ->
let partition = partitionAttributes ~partDoc ~allowUncurry atTl in
{ partition with stylisticAttrs = attr :: partition.stylisticAttrs }
| ({ attr_name = { txt = "reason.preserve_braces"; _ }; _ } as attr) :: atTl
->
let partition = partitionAttributes ~partDoc ~allowUncurry atTl in
{ partition with stylisticAttrs = attr :: partition.stylisticAttrs }
| ({ attr_name = { txt = "reason.openSyntaxNotation"; _ }; _ } as attr)
:: atTl ->
let partition = partitionAttributes ~partDoc ~allowUncurry atTl in
{ partition with stylisticAttrs = attr :: partition.stylisticAttrs }
| ({ attr_name = { txt = "reason.quoted_extension"; _ }; _ } as attr) :: atTl
->
let partition = partitionAttributes ~partDoc ~allowUncurry atTl in
{ partition with stylisticAttrs = attr :: partition.stylisticAttrs }
| atHd :: atTl ->
let partition = partitionAttributes ~partDoc ~allowUncurry atTl in
{ partition with stdAttrs = atHd :: partition.stdAttrs }
let extractStdAttrs attrs = (partitionAttributes attrs).stdAttrs
let extract_raw_literal attrs =
let rec loop acc = function
| { attr_name = { txt = "reason.raw_literal"; _ }
; attr_payload =
PStr
[ { pstr_desc =
Pstr_eval
( { pexp_desc = Pexp_constant (Pconst_string (text, _, None))
; _
}
, _ )
; _
}
]
; _
}
:: rest ->
Some text, List.rev_append acc rest
| [] -> None, List.rev acc
| attr :: rest -> loop (attr :: acc) rest
in
loop [] attrs
let without_stylistic_attrs attrs =
let rec loop acc = function
| attr :: rest when (partitionAttributes [ attr ]).stylisticAttrs != [] ->
loop acc rest
| [] -> List.rev acc
| attr :: rest -> loop (attr :: acc) rest
in
loop [] attrs
(* TODO: Make this fast and not filter *)
let has_jsx_attributes =
let is_jsx_attribute { attr_name = { txt; _ }; _ } = txt = "JSX" in
fun attrs -> List.exists ~f:is_jsx_attribute attrs
let has_preserve_braces_attrs =
let is_preserve_braces_attr { attr_name = { txt; _ }; _ } =
txt = "reason.preserve_braces"
in
fun stylisticAttrs -> List.exists ~f:is_preserve_braces_attr stylisticAttrs
let has_quoted_extension_attrs =
let is_quoted_extension_attr { attr_name = { txt; _ }; _ } =
txt = "reason.quoted_extension"
in
fun stylisticAttrs -> List.exists ~f:is_quoted_extension_attr stylisticAttrs
let maybe_remove_stylistic_attrs attrs ~should_preserve =
if should_preserve
then attrs
else
List.filter
~f:(function
| { attr_name = { txt = "reason.raw_literal"; _ }; _ } -> true
| _ -> false)
attrs
let has_open_notation_attr =
let is_open_notation_attr { attr_name = { txt; _ }; _ } =
txt = "reason.openSyntaxNotation"
in
fun stylisticAttrs -> List.exists ~f:is_open_notation_attr stylisticAttrs
================================================
FILE: src/reason-parser/reason_attributes.mli
================================================
open Ppxlib
type attributesPartition =
{ arityAttrs : attributes
; docAttrs : attributes
; stdAttrs : attributes
; jsxAttrs : attributes
; stylisticAttrs : attributes
; uncurried : bool
}
(** Kinds of attributes *)
val partitionAttributes :
?partDoc:bool
-> ?allowUncurry:bool
-> attribute list
-> attributesPartition
(** Partition attributes into kinds *)
val extract_raw_literal : attribute list -> label option * attribute list
val maybe_remove_stylistic_attrs :
attribute list
-> should_preserve:bool
-> attribute list
val without_stylistic_attrs : attribute list -> attribute list
val has_open_notation_attr : attribute list -> bool
val has_jsx_attributes : attribute list -> bool
val has_preserve_braces_attrs : attribute list -> bool
val has_quoted_extension_attrs : attribute list -> bool
val extractStdAttrs : attribute list -> attributes
================================================
FILE: src/reason-parser/reason_comment.ml
================================================
type category =
| EndOfLine
| SingleLine
| Regular
type t =
{ location : Location.t
; category : category
; text : string
}
let category t = t.category
let location t = t.location
let wrap t =
match t.text with
| "" | "*" -> "/***/"
| txt when Reason_syntax_util.isLineComment txt ->
"//"
(* single line comments of the form `// comment` have a `\n` at the end *)
^ String.sub txt ~pos:0 ~len:(String.length txt - 1)
^ Reason_syntax_util.EOLMarker.string
| txt when txt.[0] = '*' && txt.[1] <> '*' ->
(* CHECK: this comment printing seems fishy.
* It apply to invalid docstrings.
* In this case, it will add a spurious '*'.
* E.g. /**
* * bla */
* In an invalid context is turned into
* /***
* * bla */
* I think this case should be removed.
*)
"/**" ^ txt ^ "*/"
| txt -> "/*" ^ txt ^ "*/"
let make ~location category text = { text; category; location }
let isLineComment { category; text; _ } =
match category with
| SingleLine -> Reason_syntax_util.isLineComment text
| EndOfLine | Regular -> false
================================================
FILE: src/reason-parser/reason_comment.mli
================================================
type category =
| EndOfLine
| SingleLine
| Regular
type t =
{ location : Location.t
; category : category
; text : string
}
val category : t -> category
val location : t -> Location.t
val wrap : t -> string
val make : location:Location.t -> category -> string -> t
val isLineComment : t -> bool
================================================
FILE: src/reason-parser/reason_config.ml
================================================
(** * Copyright (c) 2015-present, Facebook, Inc. * * This source code is
licensed under the MIT license found in the * LICENSE file in the root
directory of this source tree. *)
let recoverable = ref false
let configure ~recoverable:r = recoverable := r
================================================
FILE: src/reason-parser/reason_config.mli
================================================
(** * Copyright (c) 2015-present, Facebook, Inc. * * This source code is
licensed under the MIT license found in the * LICENSE file in the root
directory of this source tree. *)
val recoverable : bool ref
val configure : recoverable:bool -> unit
================================================
FILE: src/reason-parser/reason_declarative_lexer.mli
================================================
type state
val keyword_table : (string, Reason_parser.token) Hashtbl.t
val make : unit -> state
val token : state -> Lexing.lexbuf -> Reason_parser.token
================================================
FILE: src/reason-parser/reason_declarative_lexer.mll
================================================
(*
* Copyright (c) 2015-present, Facebook, Inc.
*
* This source code is licensed under the MIT license found in the
* LICENSE file in the root directory of this source tree.
*
* Forked from OCaml, which is provided under the license below:
*
* Xavier Leroy, projet Cristal, INRIA Rocquencourt
*
* Copyright © 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006 Inria
*
* Permission is hereby granted, free of charge, to the Licensee obtaining a
* copy of this software and associated documentation files (the "Software"),
* to deal in the Software without restriction, including without limitation
* the rights to use, copy, modify, merge, publish, distribute, sublicense
* under any license of the Licensee's choice, and/or sell copies of the
* Software, subject to the following conditions:
*
* 1. Redistributions of source code must retain the above copyright notice
* and the following disclaimer.
* 2. Redistributions in binary form must reproduce the above copyright
* notice, the following disclaimer in the documentation and/or other
* materials provided with the distribution.
* 3. All advertising materials mentioning features or use of the Software
* must display the following acknowledgement: This product includes all or
* parts of the Caml system developed by Inria and its contributors.
* 4. Other than specified in clause 3, neither the name of Inria nor the
* names of its contributors may be used to endorse or promote products
* derived from the Software without specific prior written permission.
*
* Disclaimer
*
* This software is provided by Inria and contributors “as is” and any express
* or implied warranties, including, but not limited to, the implied
* warranties of merchantability and fitness for a particular purpose are
* disclaimed. in no event shall Inria or its contributors be liable for any
* direct, indirect, incidental, special, exemplary, or consequential damages
* (including, but not limited to, procurement of substitute goods or
* services; loss of use, data, or profits; or business interruption) however
* caused and on any theory of liability, whether in contract, strict
* liability, or tort (including negligence or otherwise) arising in any way
* out of the use of this software, even if advised of the possibility of such
* damage.
*
*)
(* This is the Reason lexer. As stated in src/README, there's a good section in
Real World OCaml that describes what a lexer is:
https://realworldocaml.org/v1/en/html/parsing-with-ocamllex-and-menhir.html
Basically, it uses regular expressions to first cut the big code string into
more meaningful chunks, called tokens. For example, it cuts the string
let foo = 1
into `let`, `foo`, `=` and `1`, massage them a bit into nice variants, then
send the data structures into the parser `reason_parser.mly`, which takes
care of the next step (turning the stream of tokens into an AST, abstract
syntax tree).
The file's syntax's a bit special. It's not the conventional OCaml syntax. An
ordinary language syntax isn't expressive/convenient enough for a lexer. This
mll ("ml lexer") syntax is a fine-tuned variation of the usual OCaml syntax.
*)
{
open Lexing
open Reason_parser
open Reason_errors
(* The table of keywords *)
let keyword_table, _reverse_keyword_table =
let create_hashtable n l =
let t = Hashtbl.create n in
let rev_t = Hashtbl.create n in
List.iter ~f:(fun (k, v) ->
Hashtbl.add t k v;
Hashtbl.add rev_t v k;
) l;
t, rev_t
in
create_hashtable 149 [
"and", AND;
"as", AS;
"assert", ASSERT;
"begin", BEGIN;
"class", CLASS;
"constraint", CONSTRAINT;
"do", DO;
"done", DONE;
"downto", DOWNTO;
"else", ELSE;
"end", END;
"exception", EXCEPTION;
"external", EXTERNAL;
"false", FALSE;
"for", FOR;
"fun", FUN;
"esfun", ES6_FUN;
"function", FUNCTION;
"functor", FUNCTOR;
"if", IF;
"in", IN;
"include", INCLUDE;
"inherit", INHERIT;
"initializer", INITIALIZER;
"lazy", LAZY;
"let", LET;
"switch", SWITCH;
"module", MODULE;
"pub", PUB;
"mutable", MUTABLE;
"new", NEW;
"nonrec", NONREC;
"object", OBJECT;
"of", OF;
"open", OPEN;
"or", OR;
(* "parser", PARSER; *)
"pri", PRI;
"rec", REC;
"sig", SIG;
"struct", STRUCT;
"then", THEN;
"to", TO;
"true", TRUE;
"try", TRY;
"type", TYPE;
"val", VAL;
"virtual", VIRTUAL;
"when", WHEN;
"while", WHILE;
"with", WITH;
"mod", INFIXOP3("mod");
"land", INFIXOP3("land");
"lor", INFIXOP3("lor");
"lxor", INFIXOP3("lxor");
"lsl", INFIXOP4("lsl");
"lsr", INFIXOP4("lsr");
"asr", INFIXOP4("asr")
]
(* The only internal state of the lexer is two scratch buffers.
They could be allocated everytime they are needed, but
for better performance (FIXME: does this really matter?)
they are preallocated.*)
type state = {
raw_buffer : Buffer.t;
txt_buffer : Buffer.t;
}
let get_scratch_buffers { raw_buffer; txt_buffer } =
Buffer.reset raw_buffer;
Buffer.reset txt_buffer;
( raw_buffer, txt_buffer )
let flush_buffer buffer =
let result = Buffer.contents buffer in
Buffer.reset buffer;
result
let make () = {
raw_buffer = Buffer.create 255;
txt_buffer = Buffer.create 255;
}
(* Specialize raise_error for lexing errors *)
let raise_error loc error = raise_error (Lexing_error error) loc
let store_lexeme buffer lexbuf =
Buffer.add_string buffer (Lexing.lexeme lexbuf)
(* To "unlex" a few characters *)
let set_lexeme_length buf n = (
let open Lexing in
if n < 0 then
invalid_arg "set_lexeme_length: offset should be positive";
if n > buf.lex_curr_pos - buf.lex_start_pos then
invalid_arg "set_lexeme_length: offset larger than lexeme";
buf.lex_curr_pos <- buf.lex_start_pos + n;
buf.lex_curr_p <- {buf.lex_start_p
with pos_cnum = buf.lex_abs_pos + buf.lex_curr_pos};
)
let compute_quoted_string_idloc {Location.loc_start = orig_loc; _ } shift id =
let id_start_pos = orig_loc.Lexing.pos_cnum + shift in
let loc_start =
Lexing.{orig_loc with pos_cnum = id_start_pos }
in
let loc_end =
Lexing.{orig_loc with pos_cnum = id_start_pos + String.length id}
in
{Location. loc_start ; loc_end ; loc_ghost = false }
(* This cut comment characters of the current buffer.
* Operators (including "/*" and "//") are lexed with the same rule, and this
* function cuts the lexeme at the beginning of an operator. *)
let lexeme_without_comment buf = (
let lexeme = Lexing.lexeme buf in
let i = ref 0 and len = String.length lexeme - 1 in
let found = ref (-1) in
while !i < len && !found = -1 do
begin match lexeme.[!i], lexeme.[!i+1] with
| ('/', '*') | ('/', '/') | ('*', '/') ->
found := !i;
| _ -> ()
end;
incr i
done;
match !found with
| -1 -> lexeme
| n ->
set_lexeme_length buf n;
String.sub lexeme ~pos:0 ~len:n
)
(* Operators that could conflict with comments (those containing /*, */ and //)
* are escaped in the source. The lexer removes the escapes so that the
* identifier looks like OCaml ones.
* An escape in first position is kept to distinguish "verbatim" operators
* (\=== for instance). *)
let unescape_operator str =
if (str <> "" && String.contains_from str 1 '\\') then (
let b = Buffer.create (String.length str) in
Buffer.add_char b str.[0];
for i = 1 to String.length str - 1 do
let c = str.[i] in
if c <> '\\' then Buffer.add_char b c
done;
Buffer.contents b
) else str
let lexeme_operator lexbuf =
unescape_operator (lexeme_without_comment lexbuf)
(* To translate escape sequences *)
let hex_digit_value d = (* assert (d in '0'..'9' 'a'..'f' 'A'..'F') *)
let d = Char.code d in
if d >= 97 then d - 87 else
if d >= 65 then d - 55 else
d - 48
let hex_num_value lexbuf ~first ~last =
let rec loop acc i = match i > last with
| true -> acc
| false ->
let value = hex_digit_value (Lexing.lexeme_char lexbuf i) in
loop (16 * acc + value) (i + 1)
in
loop 0 first
let char_for_backslash = function
| 'n' -> '\010'
| 'r' -> '\013'
| 'b' -> '\008'
| 't' -> '\009'
| c -> c
let char_for_decimal_code lexbuf i =
let c = 100 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) +
10 * (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) +
(Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48) in
if (c < 0 || c > 255) then (
raise_error
(Location.curr lexbuf)
(Illegal_escape (Lexing.lexeme lexbuf));
'x'
) else Char.chr c
let char_for_hexadecimal_code lexbuf i =
let byte = hex_num_value lexbuf ~first:i ~last:(i+1) in
Char.chr byte
let uchar_for_uchar_escape lexbuf =
let err e =
raise_error (Location.curr lexbuf) (Illegal_escape (Lexing.lexeme lexbuf ^ e));
Uchar.of_char 'u'
in
let len = Lexing.lexeme_end lexbuf - Lexing.lexeme_start lexbuf in
let first = 3 (* skip opening \u{ *) in
let last = len - 2 (* skip closing } *) in
let digit_count = last - first + 1 in
match digit_count > 6 with
| true -> err ", too many digits, expected 1 to 6 hexadecimal digits"
| false ->
let cp = hex_num_value lexbuf ~first ~last in
if Uchar.is_valid cp then Uchar.unsafe_of_int cp else
err (", " ^ Printf.sprintf "%X" cp ^ " is not a Unicode scalar value")
let validate_encoding lexbuf raw_name =
match Ocaml_util.Utf8_lexeme.normalize raw_name with
| Error _ ->
raise_error (Location.curr lexbuf) (Invalid_encoding raw_name);
raw_name
| Ok name -> name
let ident_for_extended lexbuf raw_name =
let name = validate_encoding lexbuf raw_name in
match Ocaml_util.Utf8_lexeme.validate_identifier name with
| Ocaml_util.Utf8_lexeme.Valid -> name
| Invalid_character u ->
raise_error (Location.curr lexbuf) (Invalid_char_in_ident u);
raw_name
| Invalid_beginning _ ->
assert false (* excluded by the regexps *)
let validate_delim lexbuf raw_name =
let name = validate_encoding lexbuf raw_name in
if Ocaml_util.Utf8_lexeme.is_lowercase name then name
else (raise_error (Location.curr lexbuf) (Non_lowercase_delimiter name); raw_name)
let validate_ext lexbuf name =
let name = validate_encoding lexbuf name in
match Ocaml_util.Utf8_lexeme.validate_identifier ~with_dot:true name with
| Ocaml_util.Utf8_lexeme.Valid -> name
| Invalid_character u -> raise_error (Location.curr lexbuf) (Invalid_char_in_ident u); name
| Invalid_beginning _ ->
assert false (* excluded by the regexps *)
let lax_delim raw_name =
match Ocaml_util.Utf8_lexeme.normalize raw_name with
| Error _ -> None
| Ok name ->
if Ocaml_util.Utf8_lexeme.is_lowercase name then Some name
else None
(* Update the current location with file name and line number. *)
let update_loc lexbuf file line absolute chars =
let pos = lexbuf.lex_curr_p in
let new_file = match file with
| None -> pos.pos_fname
| Some s -> s
in
lexbuf.lex_curr_p <- { pos with
pos_fname = new_file;
pos_lnum = if absolute then line else pos.pos_lnum + line;
pos_bol = pos.pos_cnum - chars;
}
}
let newline = ('\013'* '\010')
let blank = [' ' '\009' '\012']
let lowercase = ['a'-'z' '_']
let lowercase_no_under = ['a'-'z']
let uppercase = ['A'-'Z']
let identstart = lowercase | uppercase
let identchar = ['A'-'Z' 'a'-'z' '_' '\'' '0'-'9']
let utf8 = ['\192'-'\255'] ['\128'-'\191']*
let identstart_ext = identstart | utf8
let identchar_ext = identchar | utf8
let operator_chars =
['!' '$' '%' '&' '+' '-' ':' '<' '=' '>' '?' '@' '^' '|' '~' '#' '.'] |
( '\\'? ['/' '*'] )
let dotsymbolchar =
['!' '$' '%' '&' '*' '+' '-' '/' ':' '=' '>' '?' '@' '^' '|' '\\' 'a'-'z' 'A'-'Z' '_' '0'-'9']
let kwdopchar = ['$' '&' '*' '+' '-' '/' '<' '=' '>' '@' '^' '|' '.' '!']
let ident = (lowercase | uppercase) identchar*
let ident_ext = identstart_ext identchar_ext*
let extattrident = ident_ext ('.' ident_ext)*
let decimal_literal = ['0'-'9'] ['0'-'9' '_']*
let hex_digit =
['0'-'9' 'A'-'F' 'a'-'f']
let hex_literal =
'0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']['0'-'9' 'A'-'F' 'a'-'f' '_']*
let oct_literal =
'0' ['o' 'O'] ['0'-'7'] ['0'-'7' '_']*
let bin_literal =
'0' ['b' 'B'] ['0'-'1'] ['0'-'1' '_']*
let int_literal =
decimal_literal | hex_literal | oct_literal | bin_literal
let float_literal =
['0'-'9'] ['0'-'9' '_']*
('.' ['0'-'9' '_']* )?
(['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']*)?
let hex_float_literal =
'0' ['x' 'X']
['0'-'9' 'A'-'F' 'a'-'f'] ['0'-'9' 'A'-'F' 'a'-'f' '_']*
('.' ['0'-'9' 'A'-'F' 'a'-'f' '_']* )?
(['p' 'P'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']* )?
let literal_modifier = ['G'-'Z' 'g'-'z']
let raw_ident_escape = "\\#"
rule token state = parse
| "\\" newline {
raise_error
(Location.curr lexbuf)
(Illegal_character (Lexing.lexeme_char lexbuf 0));
update_loc lexbuf None 1 false 0;
token state lexbuf
}
| newline
{ update_loc lexbuf None 1 false 0;
token state lexbuf
}
| blank +
{ token state lexbuf }
| "_"
{ UNDERSCORE }
| "~"
{ TILDE }
| "?"
{ QUESTION }
| "=?"
{ set_lexeme_length lexbuf 1; EQUAL }
| raw_ident_escape (lowercase identchar * as name)
{ LIDENT name }
| lowercase identchar *
{ let s = Lexing.lexeme lexbuf in
try Hashtbl.find keyword_table s
with Not_found -> LIDENT s
}
| uppercase identchar *
{ UIDENT(Lexing.lexeme lexbuf) } (* No capitalized keywords *)
| (raw_ident_escape? as escape) (ident_ext as raw_name)
{ let name = ident_for_extended lexbuf raw_name in
if Ocaml_util.Utf8_lexeme.is_capitalized name then begin
if escape="" then UIDENT name
else
(* we don't have capitalized keywords, and thus no needs for
capitalized raw identifiers. *)
(raise_error (Location.curr lexbuf) (Capitalized_raw_identifier name);
UIDENT name)
end else
LIDENT name
} (* No non-ascii keywords *)
| int_literal
{ INT (Lexing.lexeme lexbuf, None) }
| (int_literal as lit) (literal_modifier as modif)
{ INT (lit, Some modif) }
| float_literal | hex_float_literal
{ FLOAT (Lexing.lexeme lexbuf, None) }
| ((float_literal | hex_float_literal) as lit) (literal_modifier as modif)
{ FLOAT (lit, Some modif) }
| ((float_literal | hex_float_literal) as lit) identchar+
{ raise_error
(Location.curr lexbuf)
(Invalid_literal (Lexing.lexeme lexbuf));
FLOAT (lit, None)
}
| (int_literal as lit) identchar+
{ raise_error
(Location.curr lexbuf)
(Invalid_literal (Lexing.lexeme lexbuf));
INT (lit, None)
}
| "\""
{ let string_start = lexbuf.lex_start_p in
let start_loc = Location.curr lexbuf in
let raw_buffer, txt_buffer = get_scratch_buffers state in
if not (string raw_buffer (Some txt_buffer) lexbuf) then
raise_error start_loc Unterminated_string;
lexbuf.lex_start_p <- string_start;
let txt = flush_buffer txt_buffer in
let raw = flush_buffer raw_buffer in
STRING (txt, Some raw, None)
}
| "{" (ident_ext? as raw_name) "|"
{ let delim = validate_delim lexbuf raw_name in
let string_start = lexbuf.lex_start_p in
let start_loc = Location.curr lexbuf in
let raw_buffer, _ = get_scratch_buffers state in
if not (quoted_string raw_buffer delim lexbuf) then
raise_error start_loc Unterminated_string;
lexbuf.lex_start_p <- string_start;
let txt = flush_buffer raw_buffer in
STRING (txt, None, Some delim)
}
| "{%" (extattrident as raw_id) "|"
{ let id = validate_ext lexbuf raw_id in
let orig_loc = Location.curr lexbuf in
let string_start = lexbuf.lex_start_p in
let start_loc = Location.curr lexbuf in
let raw_buffer, _ = get_scratch_buffers state in
if not (quoted_string raw_buffer "" lexbuf) then
raise_error start_loc Unterminated_string;
lexbuf.lex_start_p <- string_start;
let txt = flush_buffer raw_buffer in
let idloc = compute_quoted_string_idloc orig_loc 2 id in
QUOTED_STRING_EXPR (id, idloc, txt, Some "") }
| "{%" (extattrident as raw_id) blank+ (ident_ext* as raw_delim) "|"
{ let orig_loc = Location.curr lexbuf in
let id = validate_ext lexbuf raw_id in
let delim = validate_delim lexbuf raw_delim in
let string_start = lexbuf.lex_start_p in
let start_loc = Location.curr lexbuf in
let raw_buffer, _ = get_scratch_buffers state in
if not (quoted_string raw_buffer delim lexbuf) then
raise_error start_loc Unterminated_string;
lexbuf.lex_start_p <- string_start;
let txt = flush_buffer raw_buffer in
let idloc = compute_quoted_string_idloc orig_loc 2 id in
QUOTED_STRING_EXPR (id, idloc, txt, Some delim) }
| "{%%" (extattrident as raw_id) "|"
{ let orig_loc = Location.curr lexbuf in
let id = validate_ext lexbuf raw_id in
let string_start = lexbuf.lex_start_p in
let start_loc = Location.curr lexbuf in
let raw_buffer, _ = get_scratch_buffers state in
if not (quoted_string raw_buffer "" lexbuf) then
raise_error start_loc Unterminated_string;
lexbuf.lex_start_p <- string_start;
let txt = flush_buffer raw_buffer in
let idloc = compute_quoted_string_idloc orig_loc 3 id in
QUOTED_STRING_ITEM (id, idloc, txt, Some "") }
| "{%%" (extattrident as raw_id) blank+ (ident_ext* as raw_delim) "|"
{ let orig_loc = Location.curr lexbuf in
let id = validate_ext lexbuf raw_id in
let delim = validate_delim lexbuf raw_delim in
let string_start = lexbuf.lex_start_p in
let start_loc = Location.curr lexbuf in
let raw_buffer, _ = get_scratch_buffers state in
if not (quoted_string raw_buffer delim lexbuf) then
raise_error start_loc Unterminated_string;
lexbuf.lex_start_p <- string_start;
let txt = flush_buffer raw_buffer in
let idloc = compute_quoted_string_idloc orig_loc 3 id in
QUOTED_STRING_ITEM (id, idloc, txt, Some delim) }
| "'" newline "'"
{ (* newline can span multiple characters
(if the newline starts with \13)
Only the first one is returned, maybe we should warn? *)
update_loc lexbuf None 1 false 1;
CHAR (Lexing.lexeme_char lexbuf 1)
}
| "'" ([^ '\\' '\'' '\010' '\013'] as c) "'"
{ CHAR c }
| "'\\" (['\\' '\'' '"' 'n' 't' 'b' 'r' ' '] as c) "'"
{ CHAR (char_for_backslash c) }
| "'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "'"
{ CHAR (char_for_decimal_code lexbuf 2) }
| "'\\" 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "'"
{ CHAR (char_for_hexadecimal_code lexbuf 3) }
| "'" (("\\" [^ '#']) as esc)
{ raise_error (Location.curr lexbuf) (Illegal_escape esc);
token state lexbuf
}
| "#=<"
{ (* Allow parsing of foo#=<bar /> *)
set_lexeme_length lexbuf 2;
SHARPEQUAL
}
| "#="
{ SHARPEQUAL }
| "#" operator_chars+
{ SHARPOP (lexeme_operator lexbuf) }
| "#" [' ' '\t']* (['0'-'9']+ as num) [' ' '\t']*
("\"" ([^ '\010' '\013' '"' ] * as name) "\"")?
[^ '\010' '\013'] * newline
{ update_loc lexbuf name (int_of_string num) true 0;
token state lexbuf
}
| "&" { AMPERSAND }
| "&&" { AMPERAMPER }
| "`" { BACKQUOTE }
| "'" { QUOTE }
| "(" { LPAREN }
| ")" { RPAREN }
| "*" { STAR }
| "," { COMMA }
| "->" { MINUSGREATER }
| "=>" { EQUALGREATER }
(* allow lexing of | `Variant =><Component /> *)
| "=><" identstart (identchar | '.') * {
set_lexeme_length lexbuf 2;
EQUALGREATER
}
| "#" { SHARP }
| "." { DOT }
| ".." { DOTDOT }
| "..."{ DOTDOTDOT }
| ":" { COLON }
| "::" { COLONCOLON }
| ":=" { COLONEQUAL }
| ":>" { COLONGREATER }
| ";" { SEMI }
| ";;" { SEMISEMI }
| "<" { LESS }
| "=" { EQUAL }
| "[" { LBRACKET }
| "[|" { LBRACKETBAR }
| "[<" { LBRACKETLESS }
| "[>" { LBRACKETGREATER }
| "<" (((uppercase identchar* '.')*
(lowercase_no_under | lowercase identchar identchar*)) as tag)
(* Parsing <_ helps resolve no conflicts in the parser and creates other
* challenges with splitting up INFIXOP0 tokens (in Reason_parser_single)
* so we don't do it. *)
{ LESSIDENT tag }
| "<" ((uppercase identchar*) as tag)
{ LESSUIDENT tag }
| ">..." { GREATERDOTDOTDOT }
(* Allow parsing of Pexp_override:
* let z = {<state: 0, x: y>};
*
* Make sure {<state is emitted as LBRACELESS.
* This contrasts with jsx:
* in a jsx context {<div needs to be LBRACE LESS (two tokens)
* for a valid parse.
*)
| "{<" identstart identchar* blank* ":"
{ set_lexeme_length lexbuf 2;
LBRACELESS
}
| "{<" identstart (identchar | '.') *
{ (* allows parsing of `{<Text` in <Description term={<Text text="Age" />}>
as correct jsx
*)
set_lexeme_length lexbuf 1;
LBRACE
}
| "{<>" {
set_lexeme_length lexbuf 1;
LBRACE
}
| "{<>}" {
set_lexeme_length lexbuf 2;
LBRACELESS
}
| "</" blank* ((identstart (identchar|'.')* ) as tag) blank* ">"
{ LESSSLASHIDENTGREATER tag }
| "]" { RBRACKET }
| "{" { LBRACE }
| "{<" { LBRACELESS }
| "|" { BAR }
| "||" { BARBAR }
| "|]" { BARRBRACKET }
| ">" { GREATER }
(* Having a GREATERRBRACKET makes it difficult to parse patterns such
as > ]. The space in between then becomes significant and must be
maintained when printing etc. >] isn't even needed!
| ">]" { GREATERRBRACKET }
*)
| "}" { RBRACE }
| ">}" { GREATERRBRACE }
| "=<" identstart+
{ (* allow `let x=<div />;` *)
set_lexeme_length lexbuf 1;
EQUAL
}
| "/>|]"
{ (* jsx in arrays: [|<div />|]*)
set_lexeme_length lexbuf 2;
SLASHGREATER
}
| "[|<"
{ set_lexeme_length lexbuf 2;
LBRACKETBAR
}
(* allow parsing of <div /></Component> *)
| "/></" identstart+
{ (* allow parsing of <div asd=1></div> *)
set_lexeme_length lexbuf 2;
SLASHGREATER
}
| "></" identstart+
{ (* allow parsing of <div asd=1></div> *)
set_lexeme_length lexbuf 1;
GREATER
}
| "><" identstart+
{ (* allow parsing of <div><span> *)
set_lexeme_length lexbuf 1;
GREATER
}
| "[@" { LBRACKETAT }
| "[%" { LBRACKETPERCENT }
| "[%%" { LBRACKETPERCENTPERCENT }
| "!" { BANG }
| "!=" { INFIXOP0 "!=" }
| "!==" { INFIXOP0 "!==" }
| "\\!=" { INFIXOP0 "!=" }
| "\\!==" { INFIXOP0 "!==" }
| "+" { PLUS }
| "+." { PLUSDOT }
| "+=" { PLUSEQ }
| "-" { MINUS }
| "-." { MINUSDOT }
| "<>" { LESSGREATER }
| "</>" { LESSSLASHGREATER }
| "<..>" { LESSDOTDOTGREATER }
| '\\'? ['~' '?' '!'] operator_chars+
{ PREFIXOP (lexeme_operator lexbuf) }
| '\\'? ['=' '<' '>' '|' '&' '$'] operator_chars*
{
(* See decompose_token in Reason_single_parser.ml for how let `x=-1` is lexed
* and broken up into multiple tokens when necessary. *)
INFIXOP0 (lexeme_operator lexbuf)
}
| '\\'? '@' operator_chars*
{ INFIXOP1 (lexeme_operator lexbuf) }
| '\\'? '^' ('\\' '.')? operator_chars*
{ match lexeme_without_comment lexbuf with
| "^." | "^|" ->
(* ^| is not an infix op in [|a^|] *)
set_lexeme_length lexbuf
(if Lexing.lexeme_char lexbuf 0 = '\\' then 2 else 1);
POSTFIXOP "^"
| "^" -> POSTFIXOP "^"
| op -> INFIXOP1 (unescape_operator op)
}
| "++" operator_chars*
{ INFIXOP1 (lexeme_operator lexbuf) }
| '\\'? ['+' '-'] operator_chars*
{ INFIXOP2 (lexeme_operator lexbuf) }
(* SLASHGREATER is an INFIXOP3 that is handled specially *)
| "/>" { SLASHGREATER }
(* The second star must be escaped so that the precedence assumptions for
* printing match those of parsing. (Imagine what could happen if the other
* rule beginning with * picked up */*, and we internally escaped it to **.
* Whe printing, we have an understanding of the precedence of "**", which
* enables us to safely print/group it, but that understanding would not
* match the *actual* precedence that it was parsed at thanks to the *other*
* rule beginning with *, picking it up instead of the special double ** rule
* below.
*)
| '\\'? '*' '\\'? '*' operator_chars*
{ INFIXOP4 (lexeme_operator lexbuf) }
| '%' { PERCENT }
| '\\'? ['/' '*'] operator_chars*
{ match lexeme_operator lexbuf with
| "" ->
(* If the operator is empty, it means the lexeme is beginning
* by a comment sequence: we let the comment lexer handle
* the case. *)
enter_comment state lexbuf
| op -> INFIXOP3 op }
| '%' operator_chars*
{ INFIXOP3 (lexeme_operator lexbuf) }
| "let" kwdopchar dotsymbolchar *
{ LETOP (Reason_syntax_util.expand_letop_identifier (lexeme_operator lexbuf)) }
| "and" kwdopchar dotsymbolchar *
{ ANDOP (Reason_syntax_util.expand_letop_identifier (lexeme_operator lexbuf)) }
| eof { EOF }
| _
{ raise_error
(Location.curr lexbuf)
(Illegal_character (Lexing.lexeme_char lexbuf 0));
token state lexbuf
}
and enter_comment state = parse
| "//" ([^'\010']* newline as line)
{ update_loc lexbuf None 1 false 0;
let physical_loc = Location.curr lexbuf in
let location = { physical_loc with
loc_end = { physical_loc.loc_end with
(* Don't track trailing `\n` in the location
* 1| // comment
* 2| let x = 1;
* By omitting the `\n` at the end of line 1, the location of the
* comment spans line 1. Otherwise the comment on line 1 would end
* on the second line. The printer looks at the closing pos_lnum
* location to interleave whitespace correct. It needs to align
* with what we visually see (i.e. it ends on line 1) *)
pos_lnum = physical_loc.loc_end.pos_lnum - 1;
pos_cnum = physical_loc.loc_end.pos_cnum + 1;
}} in
COMMENT (line, location)
}
| "//" ([^'\010']* eof as line)
{ update_loc lexbuf None 1 false 0;
let physical_loc = Location.curr lexbuf in
let location = { physical_loc with
loc_end = { physical_loc.loc_end with
pos_lnum = physical_loc.loc_end.pos_lnum - 1;
pos_cnum = physical_loc.loc_end.pos_cnum + 1;
}} in
COMMENT (line, location)
}
| "/*" ("*" "*"+)?
{ set_lexeme_length lexbuf 2;
let loc = Location.curr lexbuf in
let raw_buffer, _ = get_scratch_buffers state in
ignore (comment raw_buffer loc loc lexbuf : bool);
lexbuf.Lexing.lex_start_p <- loc.Location.loc_start;
let loc_end = lexbuf.Lexing.lex_curr_p in
COMMENT (flush_buffer raw_buffer,
{loc with Location.loc_end})
}
| "/**"
{ let loc = Location.curr lexbuf in
let raw_buffer, _ = get_scratch_buffers state in
ignore (comment raw_buffer loc loc lexbuf : bool);
lexbuf.Lexing.lex_start_p <- loc.Location.loc_start;
DOCSTRING (flush_buffer raw_buffer)
}
| "/**/"
{ DOCSTRING "" }
| "/*/"
{ let loc = Location.curr lexbuf in
Location.prerr_warning loc Warnings.Comment_start;
let raw_buffer, _ = get_scratch_buffers state in
ignore (comment raw_buffer loc loc lexbuf : bool);
let loc_end = lexbuf.Lexing.lex_curr_p in
COMMENT (flush_buffer raw_buffer,
{loc with Location.loc_end})
}
| "*/"
{ let loc = Location.curr lexbuf in
Location.prerr_warning loc Warnings.Comment_not_end;
set_lexeme_length lexbuf 1;
STAR
}
| _ { assert false }
(** [comment buffer locs lexbuf] will lex a comment from [lexbuf] and
stores its raw text in [buffer], without the /* and */ delimiters.
[locs] is a non-empty list of locations that saves the beginning
position of each nested comments.
*)
and comment buffer firstloc nestedloc = parse
| "/*"
{ store_lexeme buffer lexbuf;
if comment buffer firstloc (Location.curr lexbuf) lexbuf then (
store_lexeme buffer lexbuf;
comment buffer firstloc nestedloc lexbuf
)
else
false
}
| "*/"
{ true }
| "\""
{ Buffer.add_char buffer '"';
let string_start = Location.curr lexbuf in
let terminated_string = string buffer None lexbuf in
Buffer.add_char buffer '"';
if terminated_string then
comment buffer firstloc nestedloc lexbuf
else (
raise_error nestedloc
(Unterminated_string_in_comment (firstloc, string_start));
false
)
}
| "{" ('%' '%'? extattrident blank*)? (ident_ext? as raw_delim) "|"
{ match lax_delim raw_delim with
| None ->
store_lexeme buffer lexbuf;
comment buffer firstloc nestedloc lexbuf;
| Some delim ->
store_lexeme buffer lexbuf;
let stringloc = Location.curr lexbuf in
let terminated_string = quoted_string buffer delim lexbuf in
Buffer.add_char buffer '|';
Buffer.add_string buffer delim;
Buffer.add_char buffer '}';
if terminated_string then
comment buffer firstloc nestedloc lexbuf
else (
raise_error nestedloc
(Unterminated_string_in_comment (firstloc, stringloc));
false
)
}
| "''"
{ store_lexeme buffer lexbuf;
comment buffer firstloc nestedloc lexbuf
}
| "'" newline "'"
{ store_lexeme buffer lexbuf;
update_loc lexbuf None 1 false 1;
comment buffer firstloc nestedloc lexbuf
}
| "'" [^ '\\' '\'' '\010' '\013' ] "'"
| "'\\" ['\\' '"' '\'' 'n' 't' 'b' 'r' ' '] "'"
| "'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "'"
| "'\\" 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "'"
{ store_lexeme buffer lexbuf;
comment buffer firstloc nestedloc lexbuf
}
| eof
{ raise_error nestedloc (Unterminated_comment firstloc);
false
}
| newline
{ store_lexeme buffer lexbuf;
update_loc lexbuf None 1 false 0;
comment buffer firstloc nestedloc lexbuf
}
| _
{ store_lexeme buffer lexbuf;
comment buffer firstloc nestedloc lexbuf
}
(** [string rawbuf txtbuf lexbuf] parses a string from [lexbuf].
The string contents is stored in two buffers:
- [rawbuf] for the text as it literally appear in the source
- [txtbuf] for the processed, unescaped contents.
[txtbuf] is optional. If it is omitted, contents is not unescaped.
The call returns [true] iff the string was properly terminated.
It does not register an error if the string is unterminated, this
is the responsibility of the caller.
*)
and string rawbuf txtbuf = parse
| '"'
{ true }
| '\\' newline ([' ' '\t'] * as space)
{ store_lexeme rawbuf lexbuf;
update_loc lexbuf None 1 false (String.length space);
string rawbuf txtbuf lexbuf
}
| '\\' (['\\' '\'' '"' 'n' 't' 'b' 'r' ' '] as c)
{ store_lexeme rawbuf lexbuf;
begin match txtbuf with
| None -> ()
| Some buf -> Buffer.add_char buf (char_for_backslash c);
end;
string rawbuf txtbuf lexbuf
}
| '\\' ['0'-'9'] ['0'-'9'] ['0'-'9']
{ store_lexeme rawbuf lexbuf;
begin match txtbuf with
| None -> ()
| Some buf -> Buffer.add_char buf (char_for_decimal_code lexbuf 1);
end;
string rawbuf txtbuf lexbuf
}
| '\\' 'u' '{' hex_digit+ '}'
{ store_lexeme rawbuf lexbuf;
begin match txtbuf with
| None -> ()
| Some buf -> Buffer.add_utf_8_uchar buf (uchar_for_uchar_escape lexbuf)
end;
string rawbuf txtbuf lexbuf
}
| '\\' 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F']
{ store_lexeme rawbuf lexbuf;
begin match txtbuf with
| None -> ()
| Some buf -> Buffer.add_char buf (char_for_hexadecimal_code lexbuf 2);
end;
string rawbuf txtbuf lexbuf
}
| '\\' _
{ store_lexeme rawbuf lexbuf;
begin match txtbuf with
| None -> ()
| Some buf ->
store_lexeme buf lexbuf;
(* FIXME: Warnings should probably go in Reason_errors
Should be an error, but we are very lax.
raise (Error (Illegal_escape (Lexing.lexeme lexbuf),
Location.curr lexbuf))
FIXME Using Location relies too much on compiler internals
*)
Location.prerr_warning (Location.curr lexbuf)
Warnings.Illegal_backslash;
end;
string rawbuf txtbuf lexbuf
}
| newline
{ store_lexeme rawbuf lexbuf;
begin match txtbuf with
| None -> ()
| Some buf ->
store_lexeme buf lexbuf;
Location.prerr_warning (Location.curr lexbuf)
Warnings.Eol_in_string
end;
update_loc lexbuf None 1 false 0;
string rawbuf txtbuf lexbuf
}
| eof
{ false }
| _
{ store_lexeme rawbuf lexbuf;
begin match txtbuf with
| None -> ()
| Some buf -> Buffer.add_char buf (Lexing.lexeme_char lexbuf 0);
end;
string rawbuf txtbuf lexbuf
}
(** [quoted_string buffer delim lexbuf] parses a quoted string
delimited by [delim] from [lexbuf] and stores the literal text in
[buffer].
It returns:
- true if the string was properly delimited and
- false if EOF was reached before finding "|delim}".
It does not register an error if the string is unterminated, this
is the responsibility of the caller.
*)
and quoted_string buffer delim = parse
| newline
{ store_lexeme buffer lexbuf;
update_loc lexbuf None 1 false 0;
quoted_string buffer delim lexbuf
}
| eof
{ false }
| "|" (ident_ext? as raw_edelim) "}"
{ let edelim = validate_encoding lexbuf raw_edelim in
if delim = edelim then
true
else (
store_lexeme buffer lexbuf;
quoted_string buffer delim lexbuf
)
}
| _ as c
{ Buffer.add_char buffer c;
quoted_string buffer delim lexbuf
}
================================================
FILE: src/reason-parser/reason_errors.ml
================================================
open Ppxlib
type lexing_error =
| Illegal_character of char
| Illegal_escape of string
| Unterminated_comment of Location.t
| Unterminated_string
| Unterminated_string_in_comment of Location.t * Location.t
| Keyword_as_label of string
| Capitalized_label of string
| Invalid_literal of string
| Invalid_encoding of string
| Invalid_char_in_ident of Uchar.t
| Non_lowercase_delimiter of string
| Capitalized_raw_identifier of string
type ast_error =
| Not_expecting of Location.t * string
| Other_syntax_error of string
| Variable_in_scope of Location.t * string
| Applicative_path of Location.t
type parsing_error = string
type reason_error =
| Lexing_error of lexing_error
| Parsing_error of parsing_error
| Ast_error of ast_error
exception Reason_error of reason_error * Location.t
let catch_errors : (reason_error * Location.t) list ref option ref = ref None
let raise_error error loc =
match !catch_errors with
| None -> raise (Reason_error (error, loc))
| Some caught -> caught := (error, loc) :: !caught
let raise_fatal_error error loc = raise (Reason_error (error, loc))
let recover_non_fatal_errors f =
let catch_errors0 = !catch_errors in
let errors = ref [] in
catch_errors := Some errors;
let result = match f () with x -> Ok x | exception exn -> Error exn in
catch_errors := catch_errors0;
result, List.rev !errors
(* Report lexing errors *)
let format_lexing_error ppf = function
| Illegal_character c ->
Format.fprintf ppf "Illegal character (%s)" (Char.escaped c)
| Illegal_escape s ->
Format.fprintf ppf "Illegal backslash escape in string or character (%s)" s
| Unterminated_comment _ -> Format.fprintf ppf "Comment not terminated"
| Unterminated_string -> Format.fprintf ppf "String literal not terminated"
| Unterminated_string_in_comment (_, loc) ->
Format.fprintf
ppf
"This comment contains an unterminated string literal@.%aString literal \
begins here"
Ocaml_common.Location.print_loc
loc
| Keyword_as_label kwd ->
Format.fprintf ppf "`%s' is a keyword, it cannot be used as label name" kwd
| Capitalized_label lbl ->
Format.fprintf
ppf
"`%s' cannot be used as label name, it must start with a lowercase letter"
lbl
| Invalid_literal s -> Format.fprintf ppf "Invalid literal %s" s
| Invalid_encoding s ->
Format.fprintf ppf "Invalid encoding of identifier %s." s
| Invalid_char_in_ident u ->
Format.fprintf ppf "Invalid character U+%X in identifier" (Uchar.to_int u)
| Capitalized_raw_identifier lbl ->
Format.fprintf
ppf
"`%s' cannot be used as a raw identifier, it must start with a lowercase \
letter"
lbl
| Non_lowercase_delimiter name ->
Format.fprintf
ppf
"`%s' cannot be used as a quoted string delimiter,@ it must contain only \
lowercase letters."
name
let format_parsing_error ppf msg = Format.fprintf ppf "%s" msg
let format_ast_error ppf = function
| Not_expecting (loc, nonterm) ->
Format.fprintf
ppf
"Syntax error: %a%s not expected."
Ocaml_common.Location.print_loc
loc
nonterm
| Applicative_path loc ->
Format.fprintf
ppf
"Syntax error: %aapplicative paths of the form F(X).t are not supported \
when the option -no-app-func is set."
Ocaml_common.Location.print_loc
loc
| Variable_in_scope (loc, var) ->
Format.fprintf
ppf
"%aIn this scoped type, variable '%s is reserved for the local type %s."
Ocaml_common.Location.print_loc
loc
var
var
| Other_syntax_error msg -> Format.fprintf ppf "%s" msg
let format_error ppf = function
| Lexing_error err -> format_lexing_error ppf err
| Parsing_error err -> format_parsing_error ppf err
| Ast_error err -> format_ast_error ppf err
let report_error ppf ~loc err =
Format.fprintf
ppf
"@[%a@]@."
(Ocaml_util.print_error ~loc ~f:format_error)
err
let recover_parser_error f loc msg =
if !Reason_config.recoverable
then f loc msg
else raise_fatal_error (Parsing_error msg) loc
let () =
Printexc.register_printer (function
| Reason_error (err, loc) ->
let _ = Format.flush_str_formatter () in
report_error Format.str_formatter ~loc err;
Some (Format.flush_str_formatter ())
| _ -> None)
let str_eval_message text =
{ Parsetree.pstr_loc = Location.none
; pstr_desc =
Pstr_eval
( { pexp_loc = Location.none
; pexp_desc =
Pexp_constant
(Parsetree.Pconst_string (text, Location.none, None))
; pexp_attributes = []
; pexp_loc_stack = []
}
, [] )
}
(** Generate a suitable extension node for Merlin's consumption, for the
purposes of reporting a parse error - only used in recovery mode. Parse
error will prevent Merlin from reporting subsequent errors, as they might be
due wrong recovery decisions and will confuse the user. *)
let error_extension_node_from_recovery loc msg =
recover_parser_error
(fun loc msg ->
let str = { Location.loc; txt = "merlin.syntax-error" } in
let payload = [ str_eval_message msg ] in
str, Parsetree.PStr payload)
loc
msg
(** Generate a suitable extension node for OCaml consumption, for the purposes
of reporting a syntax error. Contrary to
[error_extension_node_from_recovery], these work both with OCaml and with
Merlin. *)
let error_extension_node loc msg =
recover_parser_error
(fun loc msg ->
let str = { Location.loc; txt = "ocaml.error" } in
let payload =
[ str_eval_message msg; (* if_highlight *) str_eval_message msg ]
in
str, Parsetree.PStr payload)
loc
msg
================================================
FILE: src/reason-parser/reason_errors.mli
================================================
(** There are three main categories of error:
- _lexer errors_, thrown by Reason_lexer when the source **text is
malformed** and no token can be produced
- _concrete parsing errors_, thrown by the menhir parser / parsing loop when
a **token is unexpected**
- _abstract parsing errors_, thrown by hand-written semantic actions or
further AST checks, when the source text was incorrect but this
restriction was too fine to be captured by the grammar rules *)
open Ppxlib
type lexing_error =
| Illegal_character of char
| Illegal_escape of string
| Unterminated_comment of Location.t
| Unterminated_string
| Unterminated_string_in_comment of Location.t * Location.t
| Keyword_as_label of string
| Capitalized_label of string
| Invalid_literal of string
| Invalid_encoding of string
| Invalid_char_in_ident of Uchar.t
| Non_lowercase_delimiter of string
| Capitalized_raw_identifier of string
type ast_error =
| Not_expecting of Location.t * string
| Other_syntax_error of string
| Variable_in_scope of Location.t * string
| Applicative_path of Location.t
type parsing_error = string
type reason_error =
| Lexing_error of lexing_error
| Parsing_error of parsing_error
| Ast_error of ast_error
exception Reason_error of reason_error * Location.t
val raise_error : reason_error -> Location.t -> unit
val raise_fatal_error : reason_error -> Location.t -> 'a
val recover_non_fatal_errors :
(unit -> 'a)
-> ('a, exn) result * (reason_error * Location.t) list
val recover_parser_error :
(Location.t -> string -> 'a)
-> Location.t
-> string
-> 'a
val report_error : Format.formatter -> loc:Location.t -> reason_error -> unit
val error_extension_node_from_recovery :
Location.t
-> string
-> string Location.loc * Parsetree.payload
val error_extension_node :
Location.t
-> string
-> string Location.loc * Parsetree.payload
================================================
FILE: src/reason-parser/reason_heuristics.ml
================================================
open Ppxlib
let is_punned_labelled_expression e lbl =
match e.pexp_desc with
| Pexp_ident { txt; _ }
| Pexp_constraint ({ pexp_desc = Pexp_ident { txt; _ }; _ }, _)
| Pexp_coerce ({ pexp_desc = Pexp_ident { txt; _ }; _ }, _, _) ->
Reason_syntax_util.parse_lid lbl = txt
| _ -> false
(* We manually check the length of `Thing.map(foo, bar, baz`, * in
`Thing.map(foo, bar, baz, (a) => doStuff(a))` * because Easyformat doesn't
have a hook to change printing when a list breaks * * we check if all
arguments aside from the final one are either strings or identifiers, * where
the sum of the string contents and identifier names are less than the print
width *)
let funAppCallbackExceedsWidth ~printWidth ~args ~funExpr () =
let funLen =
match funExpr.pexp_desc with
| Pexp_ident ident ->
let identList = Longident.flatten_exn ident.txt in
let lengthOfDots = List.length identList - 1 in
let len =
List.fold_left identList ~init:lengthOfDots ~f:(fun acc curr ->
acc + String.length curr)
in
len
| _ -> -1
in
(* eats an argument & substract its length from the printWidth * as soon as
the print width reaches a sub-zero value, * we know the print width is
exceeded & returns *)
let rec aux len = function
| _ when len < 0 -> true
| [] -> false
| arg :: args ->
(match arg with
| label, ({ pexp_desc = Pexp_ident ident; _ } as e) ->
let identLen =
List.fold_left
(Longident.flatten_exn ident.txt)
~init:len
~f:(fun acc curr -> acc + String.length curr)
in
(match label with
| Nolabel -> aux (len - identLen) args
| Labelled s when is_punned_labelled_expression e s ->
aux (len - (identLen + 1)) args
| Labelled s -> aux (len - (identLen + 2 + String.length s)) args
| Optional s -> aux (len - (identLen + 3 + String.length s)) args)
| label, { pexp_desc = Pexp_constant (Pconst_string (str, _, _)); _ } ->
let strLen = String.length str in
(match label with
| Nolabel -> aux (len - strLen) args
| Labelled s -> aux (len - (strLen + 2 + String.length s)) args
| Optional s -> aux (len - (strLen + 3 + String.length s)) args)
| _ ->
(* if we encounter a non-string or non-identifier argument exit *)
true)
in
aux (printWidth - funLen) args
(* * Whether or not an identiier is small enough to justify omitting the *
trailing comma for single identifier patterns. For single identifier *
patterns, usually the identifier is not "far right" in the document, and * is
one of the last things to require breaking. We can omit the trailing comma *
in these cases because it likely will never render anyways and therefore the
* space taken up by the trailing comma doesn't disrupt wrapping length
calculations. * * For example, the `X` hardly ever benefits from a trailing
comma. * | X(y) => *)
let singleTokenPatternOmmitTrail txt = String.length txt < 4
(* Indicates whether an expression can be printed with the uncurried * dot
notation. At the moment uncurried function application & definition * only
makes sense in the context of a Pexp_apply or Pexp_fun * * Examples: * [@bs]
add(2, 3); -> add(. 2, 3); (* Pexp_apply *) * setTimeout([@bs] () =>
Js.log("hola"), 1000); (* Pexp_fun *) * -> setTimeout((.) => Js.log("hola"),
1000); *)
let melExprCanBeUncurried expr =
match Parsetree.(expr.pexp_desc) with
| Pexp_function _ | Pexp_apply _ -> true
| _ -> false
let isUnderscoreIdent expr =
match Parsetree.(expr.pexp_desc) with
| Pexp_ident { txt = Lident "_"; _ } -> true
| _ -> false
let isPipeFirst e =
match Parsetree.(e.pexp_desc) with
| Pexp_ident { txt = Longident.Lident "|."; _ } -> true
| Pexp_apply
({ pexp_desc = Pexp_ident { txt = Longident.Lident "|."; _ }; _ }, _) ->
true
| _ -> false
let isUnderscoreApplication expr =
match expr with
| { pexp_attributes = []
; pexp_desc =
Pexp_function
( { pparam_desc =
Pparam_val
( Nolabel
, None
, { ppat_desc = Ppat_var { txt = "__x"; _ }
; ppat_attributes = []
; _
} )
; _
}
:: _
, _
, _ )
; _
} ->
true
| _ -> false
(* <div> {items->Belt.Array.map(ReasonReact.string)->ReasonReact.array} </div>;
* An application with pipe first inside jsx children requires special treatment.
* Jsx children don't allow expression application, hence we need the braces
* preserved in this case. *)
let isPipeFirstWithNonSimpleJSXChild e =
match Parsetree.(e.pexp_desc) with
| Pexp_apply
( { pexp_desc = Pexp_ident { txt = Longident.Lident "|."; _ }; _ }
, [ (Nolabel, { pexp_desc = Pexp_apply _; _ }); _ ] ) ->
true
(* Handle <div> {url->a(b, _)} </div>;
* underscore sugar needs protection *)
| Pexp_apply
( { pexp_desc = Pexp_ident { txt = Longident.Lident "|."; _ }; _ }
, [ _; (Nolabel, fe) ] )
when isUnderscoreApplication fe ->
true
| _ -> false
================================================
FILE: src/reason-parser/reason_heuristics.mli
================================================
open Ppxlib
val is_punned_labelled_expression : expression -> string -> bool
val isUnderscoreIdent : expression -> bool
val isUnderscoreApplication : expression -> bool
val melExprCanBeUncurried : expression -> bool
val isPipeFirst : expression -> bool
val isPipeFirstWithNonSimpleJSXChild : expression -> bool
val singleTokenPatternOmmitTrail : string -> bool
val funAppCallbackExceedsWidth :
printWidth:int
-> args:(arg_label * expression) list
-> funExpr:expression
-> unit
-> bool
================================================
FILE: src/reason-parser/reason_layout.ml
================================================
module Easy_format = Reason_easy_format
type break_criterion =
| Never
| IfNeed
| Always
(* Always_rec not only will break, it will break recursively up to the root *)
| Always_rec
(* Modeling separators: Special ability to render the final separator
distinctly. This is so we can replace them when they do/don't occur next to
newlines.
If sepLeft:true { final item1 sep item2 sep item3 }
If sepLeft:false { item1 sep item2 sep item3 final } *)
(* You can't determine the final separator unless you specify a separator *)
type separator =
| NoSep
| Sep of string
| SepFinal of string * string
(** * Module concerning info to correctly interleave whitespace above a layout
node. *)
module WhitespaceRegion = struct
type t =
{ (* range of the region *)
range : Reason_location.Range.t
; (* inserted comments into the whitespace region *)
comments : Reason_comment.t list
; (* amount of newlines to be interleaved *)
newlines : int
}
let make ~range ~newlines = { range; comments = []; newlines }
let newlines t = t.newlines
let range t = t.range
let comments t = t.comments
let addComment t comment = { t with comments = comment :: t.comments }
let modifyNewlines t newNewlines = { t with newlines = newNewlines }
end
(** * These represent "intent to format" the AST, with some parts being
annotated * with original source location. The benefit of tracking this in
an * intermediate structure, is that we can then interleave comments
throughout * the tree before generating the final representation. That
prevents the * formatting code from having to thread comments everywhere. *
* The final representation is rendered using Easy_format. *)
type t =
| SourceMap of Location.t * t (* a layout with location info *)
| Sequence of config * t list
| Label of (Easy_format.t -> Easy_format.t -> Easy_format.t) * t * t
| Easy of Easy_format.t
(* Extra variant representing "intent to interleave whitespace" above a
* layout node. Why the extra representation?
* Since comments get interleaved after formatting the ast,
* the inserting of actual newlines has to happen after the comments
* have been formatted/inserted. *)
| Whitespace of WhitespaceRegion.t * t
and config =
{ break : break_criterion
; (* Break setting that becomes activated if a comment becomes interleaved into
* this list. Typically, if not specified, the behavior from [break] will be
* used.
*)
wrap : string * string
; inline : bool * bool
; sep : separator
; indent : int
; sepLeft : bool
; preSpace : bool
; (* Really means space_after_separator *)
postSpace : bool
; pad : bool * bool
; (* A function, because the system might rearrange your previous settings, and
* a function allows you to not be locked into some configuration that is made
* out of date by the formatting system (suppose it removes the separator
* token etc.) Having a function allows you to instruct our formatter how to
* extend the "freshest" notion of the list config when comments are
* interleaved. *)
listConfigIfCommentsInterleaved : (config -> config) option
; (* Formatting to use if an item in a list had an end-of-line comment
appended *)
listConfigIfEolCommentsInterleaved : (config -> config) option
}
let source_map ?(loc = Location.none) layout =
if loc = Location.none then layout else SourceMap (loc, layout)
let default_list_settings =
{ Easy_format.space_after_opening = false
; space_after_separator = false
; space_before_separator = false
; separators_stick_left = true
; space_before_closing = false
; stick_to_label = true
; align_closing = true
; wrap_body = `No_breaks
; indent_body = 0
; list_style = Some "list"
; opening_style = None
; body_style = None
; separator_style = None
; closing_style = None
}
let easy_settings_from_config
{ break; wrap; inline; indent; preSpace; postSpace; pad; sep; _ }
=
(* TODO: Stop handling separators in Easy_format since we handle most of them
before Easy_format anyways. There's just some that we still rely on
Easy_format for. Easy_format's sep wasn't powerful enough. *)
let opn, cls = wrap in
let padOpn, padCls = pad in
let inlineStart, inlineEnd = inline in
let sepStr = match sep with NoSep -> "" | Sep s | SepFinal (s, _) -> s in
( opn
, sepStr
, cls
, { default_list_settings with
Easy_format.wrap_body =
(match break with
| Never -> `No_breaks
(* Yes, `Never_wrap is a horrible name - really means "if needed". *)
| IfNeed -> `Never_wrap
| Always -> `Force_breaks
| Always_rec -> `Force_breaks_rec)
; indent_body = indent
; space_after_separator = postSpace
; space_before_separator = preSpace
; space_after_opening = padOpn
; space_before_closing = padCls
; stick_to_label = inlineStart
; align_closing = not inlineEnd
} )
let to_easy_format layout =
let rec traverse = function
| Sequence (config, sublayouts) ->
let items = List.map ~f:traverse sublayouts in
Easy_format.List (easy_settings_from_config config, items)
| Label (labelFormatter, left, right) ->
labelFormatter (traverse left) (traverse right)
| SourceMap (_, subLayout) -> traverse subLayout
| Easy e -> e
| Whitespace (_, subLayout) -> traverse subLayout
in
traverse layout
(** [getLocFromLayout] recursively takes the unioned location of its children, *
and returns the max one *)
let get_location layout =
let union loc1 loc2 =
match loc1, loc2 with
| None, _ -> loc2
| _, None -> loc1
| Some loc1, Some loc2 ->
Some { loc1 with Location.loc_end = loc2.Location.loc_end }
in
let rec traverse = function
| Sequence (_, subLayouts) ->
let locs = List.map ~f:traverse subLayouts in
List.fold_left ~f:union ~init:None locs
| Label (_, left, right) -> union (traverse left) (traverse right)
| SourceMap (loc, _) -> Some loc
| Whitespace (_, sub) -> traverse sub
| _ -> None
in
traverse layout
let is_before ~location layout =
match get_location layout with
| None -> true
| Some loc -> Reason_syntax_util.location_is_before loc location
let contains_location layout ~location =
match get_location layout with
| None -> false
| Some layout_loc -> Reason_syntax_util.location_contains layout_loc location
================================================
FILE: src/reason-parser/reason_layout.mli
================================================
module Easy_format = Reason_easy_format
type break_criterion =
| Never
| IfNeed
| Always
(* Always_rec not only will break, it will break recursively up to the root *)
| Always_rec
(* Modeling separators: Special ability to render the final separator
distinctly. This is so we can replace them when they do/don't occur next to
newlines.
If sepLeft:true { final item1 sep item2 sep item3 }
If sepLeft:false { item1 sep item2 sep item3 final } *)
(* You can't determine the final separator unless you specify a separator *)
type separator =
| NoSep
| Sep of string
| SepFinal of string * string
(** * Module concerning info to correctly interleave whitespace above a layout
node. *)
module WhitespaceRegion : sig
type t =
{ (* range of the region *)
range : Reason_location.Range.t
; (* inserted comments into the whitespace region *)
comments : Reason_comment.t list
; (* amount of newlines to be interleaved *)
newlines : int
}
val make : range:Reason_location.Range.t -> newlines:int -> t
val newlines : t -> int
val range : t -> Reason_location.Range.t
val comments : t -> Reason_comment.t list
val addComment : t -> Reason_comment.t -> t
val modifyNewlines : t -> int -> t
end
(** * These represent "intent to format" the AST, with some parts being
annotated * with original source location. The benefit of tracking this in
an * intermediate structure, is that we can then interleave comments
throughout * the tree before generating the final representation. That
prevents the * formatting code from having to thread comments everywhere. *
* The final representation is rendered using Easy_format. *)
type t =
| SourceMap of Location.t * t (* a layout with location info *)
| Sequence of config * t list
| Label of (Easy_format.t -> Easy_format.t -> Easy_format.t) * t * t
| Easy of Easy_format.t
(* Extra variant representing "intent to interleave whitespace" above a
* layout node. Why the extra representation?
* Since comments get interleaved after formatting the ast,
* the inserting of actual newlines has to happen after the comments
* have been formatted/inserted. *)
| Whitespace of WhitespaceRegion.t * t
and config =
{ break : break_criterion
; (* Break setting that becomes activated if a comment becomes interleaved into
* this list. Typically, if not specified, the behavior from [break] will be
* used.
*)
wrap : string * string
; inline : bool * bool
; sep : separator
; indent : int
; sepLeft : bool
; preSpace : bool
; (* Really means space_after_separator *)
postSpace : bool
; pad : bool * bool
; (* A function, because the system might rearrange your previous settings, and
* a function allows you to not be locked into some configuration that is made
* out of date by the formatting system (suppose it removes the separator
* token etc.) Having a function allows you to instruct our formatter how to
* extend the "freshest" notion of the list config when comments are
* interleaved. *)
listConfigIfCommentsInterleaved : (config -> config) option
; (* Formatting to use if an item in a list had an end-of-line comment
appended *)
listConfigIfEolCommentsInterleaved : (config -> config) option
}
val to_easy_format : t -> Easy_format.t
val get_location : t -> Warnings.loc option
val source_map : ?loc:Warnings.loc -> t -> t
val contains_location : t -> location:Warnings.loc -> bool
val is_before : location:Warnings.loc -> t -> bool
================================================
FILE: src/reason-parser/reason_lexer.ml
================================================
open Reason_parser
type 'a positioned = 'a * Lexing.position * Lexing.position
type t =
{ declarative_lexer_state : Reason_declarative_lexer.state
; lexbuf : Lexing.lexbuf
; mutable comments : (string * Location.t) list
; mutable queued_tokens : token positioned list
; mutable queued_exn : exn option
; mutable last_cnum : int
; mutable completion_ident_offset : int
; completion_ident_pos : Lexing.position
}
let init ?insert_completion_ident lexbuf =
let declarative_lexer_state = Reason_declarative_lexer.make () in
let completion_ident_offset, completion_ident_pos =
match insert_completion_ident with
| None -> min_int, Lexing.dummy_pos
| Some pos -> pos.Lexing.pos_cnum, pos
in
{ declarative_lexer_state
; lexbuf
; comments = []
; queued_tokens = []
; queued_exn = None
; last_cnum = -1
; completion_ident_offset
; completion_ident_pos
}
let lexbuf state = state.lexbuf
let rec token state =
match
Reason_declarative_lexer.token state.declarative_lexer_state state.lexbuf
with
| COMMENT (s, comment_loc) ->
state.comments <- (s, comment_loc) :: state.comments;
token state
| tok -> tok
(* Routines for manipulating lexer state *)
let save_triple lexbuf tok =
tok, lexbuf.Lexing.lex_start_p, lexbuf.Lexing.lex_curr_p
let fake_triple t (_, pos, _) = t, pos, pos
(* insert ES6_FUN *)
exception Lex_balanced_failed of token positioned list * exn option
let closing_of = function
| LPAREN -> RPAREN
| LBRACE -> RBRACE
| _ -> assert false
let inject_es6_fun = function
| tok :: acc -> tok :: fake_triple ES6_FUN tok :: acc
| _ -> assert false
let is_triggering_token = function EQUALGREATER | COLON -> true | _ -> false
let rec lex_balanced_step state closing acc tok =
let lexbuf = state.lexbuf in
let acc = save_triple lexbuf tok :: acc in
match tok, closing with
| RPAREN, RPAREN | RBRACE, RBRACE | RBRACKET, RBRACKET -> acc
| (RPAREN | RBRACE | RBRACKET | EOF), _ ->
raise (Lex_balanced_failed (acc, None))
| ( ( LBRACKET | LBRACKETLESS | LBRACKETGREATER | LBRACKETAT | LBRACKETPERCENT
| LBRACKETPERCENTPERCENT )
, _ ) ->
lex_balanced state closing (lex_balanced state RBRACKET acc)
| (LPAREN | LBRACE), _ ->
let rparen =
try lex_balanced state (closing_of tok) [] with
| Lex_balanced_failed (rparen, None) ->
raise (Lex_balanced_failed (rparen @ acc, None))
in
(match token state with
| exception exn -> raise (Lex_balanced_failed (rparen @ acc, Some exn))
| tok' ->
let acc = if is_triggering_token tok' then inject_es6_fun acc else acc in
lex_balanced_step state closing (rparen @ acc) tok')
| (LIDENT _ | UNDERSCORE), _ ->
(match token state with
| exception exn -> raise (Lex_balanced_failed (acc, Some exn))
| tok' ->
let acc = if is_triggering_token tok' then inject_es6_fun acc else acc in
lex_balanced_step state closing acc tok')
(* `...` with a closing `}` indicates that we're definitely not in an es6_fun
* Image the following:
* true ? (Update({...a, b: 1}), None) : x;
* true ? ({...a, b: 1}) : a;
* true ? (a, {...a, b: 1}) : a;
* The lookahead_esfun is triggered initiating the lex_balanced procedure.
* Since we now "over"-parse spread operators in pattern position (for
* better errors), the ... pattern in ({...a, b: 1}) is now a valid path.
* This means that the above expression `({...a, b: 1}) :` is seen as a pattern.
* I.e. the arguments of an es6 function: (pattern) :type => expr
* We exit here, to indicate that an expression needs to be parsed instead
* of a pattern.
*)
| DOTDOTDOT, RBRACE -> acc
| _ -> lex_balanced state closing acc
and lex_balanced state closing acc =
match token state with
| exception exn -> raise (Lex_balanced_failed (acc, Some exn))
| tok -> lex_balanced_step state closing acc tok
let lookahead_esfun state ((tok, _, _) as lparen) =
match lex_balanced state (closing_of tok) [] with
| exception Lex_balanced_failed (tokens, exn) ->
state.queued_tokens <- List.rev tokens;
state.queued_exn <- exn;
lparen
| tokens ->
(match token state with
| exception exn ->
state.queued_tokens <- List.rev tokens;
state.queued_exn <- Some exn;
lparen
| token ->
let tokens = save_triple state.lexbuf token :: tokens in
if is_triggering_token token
then (
state.queued_tokens <- lparen :: List.rev tokens;
fake_triple ES6_FUN lparen)
else (
state.queued_tokens <- List.rev tokens;
lparen))
let token state =
let lexbuf = state.lexbuf in
match state.queued_tokens, state.queued_exn with
| [], Some exn ->
state.queued_exn <- None;
raise exn
| [ ((LPAREN, _, _) as lparen) ], None -> lookahead_esfun state lparen
| [ ((LBRACE, _, _) as lparen) ], None -> lookahead_esfun state lparen
| [], None ->
(match token state with
| (LPAREN | LBRACE) as tok ->
lookahead_esfun state (save_triple state.lexbuf tok)
| (LIDENT _ | UNDERSCORE) as tok ->
let tok = save_triple lexbuf tok in
(match token state with
| exception exn ->
state.queued_exn <- Some exn;
tok
| tok' ->
if is_triggering_token tok'
then (
state.queued_tokens <- [ tok; save_triple lexbuf tok' ];
fake_triple ES6_FUN tok)
else (
state.queued_tokens <- [ save_triple lexbuf tok' ];
tok))
| token -> save_triple lexbuf token)
| x :: xs, _ ->
state.queued_tokens <- xs;
x
let token state =
let space_start = state.last_cnum in
let ((token', start_p, curr_p) as token) = token state in
let token_start = start_p.Lexing.pos_cnum in
let token_stop = curr_p.Lexing.pos_cnum in
state.last_cnum <- token_stop;
if
state.completion_ident_offset > min_int
&& space_start <= state.completion_ident_offset
&& token_stop >= state.completion_ident_offset
then (
match token' with
| (LIDENT _ | UIDENT _) when token_start <= state.completion_ident_offset ->
state.completion_ident_offset <- min_int;
token
| _ ->
state.queued_tokens <- token :: state.queued_tokens;
state.completion_ident_offset <- min_int;
LIDENT "_", state.completion_ident_pos, state.completion_ident_pos)
else token
type comment = string * Location.t
type invalid_docstrings = comment list
let empty_invalid_docstrings = []
let add_invalid_docstring text loc_start loc_end invalid_docstrings =
let loc = { Location.loc_start; loc_end; loc_ghost = false } in
(text, loc) :: invalid_docstrings
let get_comments state invalid_docstrings =
let cnum (_, loc) = loc.Location.loc_start.Lexing.pos_cnum in
let rec merge_comments acc = function
| [], xs | xs, [] -> List.rev_append xs acc
| (x :: _ as xs), y :: ys when cnum x >= cnum y ->
merge_comments (y :: acc) (xs, ys)
| x :: xs, ys -> merge_comments (x :: acc) (xs, ys)
in
merge_comments [] (state.comments, invalid_docstrings)
================================================
FILE: src/reason-parser/reason_lexer.mli
================================================
open Reason_parser
type t
type 'a positioned = 'a * Lexing.position * Lexing.position
val init : ?insert_completion_ident:Lexing.position -> Lexing.lexbuf -> t
val token : t -> token positioned
val lexbuf : t -> Lexing.lexbuf
type comment = string * Location.t
(* Some docstrings are not accepted by the parser and turned into comments. *)
type invalid_docstrings
val empty_invalid_docstrings : invalid_docstrings
val add_invalid_docstring :
string
-> Lexing.position
-> Lexing.position
-> invalid_docstrings
-> invalid_docstrings
val get_comments : t -> invalid_docstrings -> comment list
================================================
FILE: src/reason-parser/reason_location.ml
================================================
module Range = struct
type t =
{ lnum_start : int
; lnum_end : int
}
(** [t] represents an interval, including endpoints, * delimited by two
linenumbers. *)
(** * make a range delimited by [loc1] and [loc2] * 1| let a = 1; * 2| * 3| *
4| * 5| let b = 2; * If loc1 represents `let a = 1` and loc2 represents
`let b = 2`, * we get the range: \{lnum_start: 2; lnum_end 4\} *)
let makeRangeBetween loc1 loc2 =
Location.
{ lnum_start = loc1.loc_end.pos_lnum + 1
; lnum_end = loc2.loc_start.pos_lnum - 1
}
(** check whether [range] contains the [loc] *)
let containsLoc range (loc : Location.t) =
range.lnum_start <= loc.loc_start.pos_lnum
&& range.lnum_end >= loc.loc_end.pos_lnum
(** * checks if [range] contains whitespace. * When comments are passed, the
computation * takes the height of the comments into account. * * Example:
* 1| let a = 1; * 2| * 3| /* a multi- * 4| line comment */ * 5| let b = 1;
* The range (line 2 - line 4) has whitespace. * * 1| let a = 1; * 2| /* a
multi- * 3| line comment */ * 4| let b = 1; * The range (line 2 - line 3)
does not have whitespace. *)
let containsWhitespace ?comments ~range () =
(* compute the amount of lines the comments occupy in the given range *)
let h =
match comments with
| Some comments ->
List.fold_left
~f:(fun acc (curr : Reason_comment.t) ->
let cl = Reason_comment.location curr in
let startLnum = cl.loc_start.pos_lnum in
let endLnum = cl.loc_end.pos_lnum in
if containsLoc range cl
then acc + (endLnum - startLnum + 1)
else acc)
~init:0
comments
| None -> 0
in
range.lnum_end - range.lnum_start - h >= 0
end
(** compute if there's space (one or more line) between [loc1] and [loc2] *)
let hasSpaceBetween loc1 loc2 =
Location.(loc1.loc_start.pos_lnum - loc2.loc_end.pos_lnum) > 1
================================================
FILE: src/reason-parser/reason_location.mli
================================================
module Range : sig
type t =
{ lnum_start : int
; lnum_end : int
}
(** [t] represents an interval, including endpoints, * delimited by two
linenumbers. *)
val makeRangeBetween : Location.t -> Location.t -> t
val containsLoc : t -> Warnings.loc -> bool
val containsWhitespace :
?comments:Reason_comment.t list
-> range:t
-> unit
-> bool
end
val hasSpaceBetween : Location.t -> Location.t -> bool
(** compute if there's space (one or more line) between [loc1] and [loc2] *)
================================================
FILE: src/reason-parser/reason_multi_parser.ml
================================================
module S = Reason_single_parser
type 'a parser = 'a S.parser list
let initial entry_point position = [ S.initial entry_point position ]
type 'a step =
| Intermediate of 'a parser
| Success of 'a * Reason_lexer.invalid_docstrings
| Error
let rec fork token = function
| [] -> []
| x :: xs ->
(match S.step x token with
| S.Intermediate x' -> x :: x' :: fork token xs
| _ -> x :: fork token xs)
let rec progress_successful token acc = function
| [] -> Intermediate (List.rev acc)
| x :: xs ->
(match S.step x token with
| S.Intermediate p -> progress_successful token (p :: acc) xs
| S.Error -> progress_successful token acc xs
| S.Success (result, ds) -> Success (result, ds))
let step parsers token =
match token with
| Reason_parser.ES6_FUN, _, _ ->
(* Fork case *)
Intermediate (fork token parsers)
| _ ->
(* Regular case *)
(match parsers with
| [ x ] ->
(* Fast-path: One parser *)
(match S.step x token with
| S.Intermediate parser -> Intermediate [ parser ]
| S.Success (result, ds) -> Success (result, ds)
| S.Error -> Error)
(* Parallel parsing case *)
| x :: xs ->
(match S.step x token with
| S.Intermediate p -> progress_successful token [ p ] xs
| S.Success (result, ds) -> Success (result, ds)
| S.Error ->
(match progress_successful token [] xs with
| Intermediate [] -> Error
| result -> result))
(* Impossible case *)
| [] -> assert false)
(* Interface for recovery *)
let recover cp ds = [ S.recover cp ds ]
let recovery_env = function [] -> assert false | x :: _xs -> S.recovery_env x
================================================
FILE: src/reason-parser/reason_multi_parser.mli
================================================
type 'a parser
val initial :
(Lexing.position -> 'a Reason_parser.MenhirInterpreter.checkpoint)
-> Lexing.position
-> 'a parser
type 'a step =
| Intermediate of 'a parser
| Success of 'a * Reason_lexer.invalid_docstrings
| Error
val step : 'a parser -> Reason_parser.token Reason_lexer.positioned -> 'a step
(* Interface for recovery *)
val recover :
'a Reason_parser.MenhirInterpreter.checkpoint
-> Reason_lexer.invalid_docstrings
-> 'a parser
val recovery_env :
'a parser
-> 'a Reason_parser.MenhirInterpreter.env * Reason_lexer.invalid_docstrings
================================================
FILE: src/reason-parser/reason_oprint.ml
================================================
(*
* Copyright (c) 2015-present, Facebook, Inc.
*
* This source code is licensed under the MIT license found in the
* LICENSE file in the root directory of this source tree.
*
* Forked from OCaml, which is provided under the license below:
*
* Xavier Leroy, projet Cristal, INRIA Rocquencourt
*
* Copyright © 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006 Inria
*
* Permission is hereby granted, free of charge, to the Licensee obtaining a
* copy of this software and associated documentation files (the "Software"),
* to deal in the Software without restriction, including without limitation
* the rights to use, copy, modify, merge, publish, distribute, sublicense
* under any license of the Licensee's choice, and/or sell copies of the
* Software, subject to the following conditions:
*
* 1. Redistributions of source code must retain the above copyright notice
* and the following disclaimer.
* 2. Redistributions in binary form must reproduce the above copyright
* notice, the following disclaimer in the documentation and/or other
* materials provided with the distribution.
* 3. All advertising materials mentioning features or use of the Software
* must display the following acknowledgement: This product includes all or
* parts of the Caml system developed by Inria and its contributors.
* 4. Other than specified in clause 3, neither the name of Inria nor the
* names of its contributors may be used to endorse or promote products
* derived from the Software without specific prior written permission.
*
* Disclaimer
*
* This software is provided by Inria and contributors “as is” and any express
* or implied warranties, including, but not limited to, the implied
* warranties of merchantability and fitness for a particular purpose are
* disclaimed. in no event shall Inria or its contributors be liable for any
* direct, indirect, incidental, special, exemplary, or consequential damages
* (including, but not limited to, procurement of substitute goods or
* services; loss of use, data, or profits; or business interruption) however
* caused and on any theory of liability, whether in contract, strict
* liability, or tort (including negligence or otherwise) arising in any way
* out of the use of this software, even if advised of the possibility of such
* damage.
*
*)
(* Hello! Welcome to the Reason "outcome printer" logic. This logic takes the
AST nodes and turn them into text, for Merlin, rtop and terminal errors
reporting to be in Reason syntax.
If you've navigated around in the Reason codebase, you might have seen the
other printer called reason_pprint_ast, our actual, main pretty-printer. Why
is this one separated from reason_pprint_ast? Because the outcome printer's
use-case is a bit different and needs different entry points blablabla...
These are mostly excuses. But for example, currently, `Js.t({. foo: bar})` by
itself is *invalid syntax* for a pretty printer (the correct, minimal valid
code would be `type myObject = Js.t({. foo: bar})`), but the terminal error
report do want to provide just that snippet and have you print it. Hopefully
OCaml can unify actual code pretty-printing and terminal type info pretty-
printing one day.
This also means the outcome printer doesn't use the normal Parsetree,
Ast_helper and others you might have seen in other files. It has its own
small AST definition here:
https://github.com/ocaml/ocaml/blob/4.04/typing/outcometree.mli
The rest of this file's logic is just pattern-matching on these tree node
variants & using Format to pretty-print them nicely. *)
open Format
module Reason_ast = Reason_omp.Ast_414
module Outcometree = Reason_ast.Outcometree
open Outcometree
exception Ellipsis
let cautious f ppf arg = try f ppf arg with Ellipsis -> fprintf ppf "..."
let rec print_ident ppf = function
| Oide_ident s -> pp_print_string ppf s.printed_name
| Oide_dot (id, s) ->
print_ident ppf id;
pp_print_char ppf '.';
pp_print_string ppf s
| Oide_apply (id1, id2) ->
fprintf ppf "%a(%a)" print_ident id1 print_ident id2
let parenthesized_ident name =
List.mem name ~set:[ "or"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr" ]
||
match name.[0] with
| 'a' .. 'z' | 'A' .. 'Z' | '\223' .. '\246' | '\248' .. '\255' | '_' -> false
| _ -> true
let value_ident ppf name =
if parenthesized_ident name
then fprintf ppf "( %s )" (Reason_syntax_util.ml_to_reason_swap name)
else pp_print_string ppf name
(* Values *)
let valid_float_lexeme s =
let l = String.length s in
let rec loop i =
if i >= l
then s ^ "."
else match s.[i] with '0' .. '9' | '-' -> loop (i + 1) | _ -> s
in
loop 0
let float_repres f =
match classify_float f with
| FP_nan -> "nan"
| FP_infinite -> if f < 0.0 then "neg_infinity" else "infinity"
| _ ->
let float_val =
let s1 = Printf.sprintf "%.12g" f in
if f = float_of_string s1
then s1
else
let s2 = Printf.sprintf "%.15g" f in
if f = float_of_string s2 then s2 else Printf.sprintf "%.18g" f
in
valid_float_lexeme float_val
let parenthesize_if_neg ppf fmt v isneg =
if isneg then pp_print_char ppf '(';
fprintf ppf fmt v;
if isneg then pp_print_char ppf ')'
let print_out_value ppf tree =
let rec print_tree_1 ppf = function
(* for the next few cases, please see context at
https://github.com/facebook/reason/pull/1516#issuecomment-337069150 *)
| Oval_constr
(name, [ Oval_constr (Oide_ident { printed_name = "()" }, []) ]) ->
(* for normal variants, but sugar Foo(()) to Foo() *)
fprintf ppf "@[<1>%a()@]" print_ident name
| Oval_constr (name, [ param ]) ->
(* for normal variants *)
fprintf ppf "@[<1>%a(%a)@]" print_ident name print_constr_param param
| Oval_constr (name, (_ :: _ as params)) ->
fprintf
ppf
"@[<1>%a(%a)@]"
print_ident
name
(print_tree_list print_tree_1 ",")
params
| Oval_variant
(name, Some (Oval_constr (Oide_ident { printed_name = "()" }, []))) ->
(* for polymorphic variants, but sugar `foo(()) to `foo() *)
fprintf ppf "@[<2>`%s()@]" name
| Oval_variant (name, Some param) ->
(* for polymorphic variants *)
fprintf ppf "@[<2>`%s(%a)@]" name print_constr_param param
| tree -> print_simple_tree ppf tree
and print_constr_param ppf = function
| Oval_int i -> parenthesize_if_neg ppf "%i" i (i < 0)
| Oval_int32 i -> parenthesize_if_neg ppf "%lil" i (i < 0l)
| Oval_int64 i -> parenthesize_if_neg ppf "%LiL" i (i < 0L)
| Oval_nativeint i -> parenthesize_if_neg ppf "%nin" i (i < 0n)
| Oval_float f -> parenthesize_if_neg ppf "%s" (float_repres f) (f < 0.0)
| tree -> print_simple_tree ppf tree
and print_simple_tree ppf = function
| Oval_int i -> fprintf ppf "%i" i
| Oval_int32 i -> fprintf ppf "%lil" i
| Oval_int64 i -> fprintf ppf "%LiL" i
| Oval_nativeint i -> fprintf ppf "%nin" i
| Oval_float f -> pp_print_string ppf (float_repres f)
| Oval_char c -> fprintf ppf "%C" c
| Oval_string (s, _, _) ->
(try fprintf ppf "\"%s\"" (Reason_syntax_util.escape_string s) with
| Invalid_argument s when s = "String.create" ->
fprintf ppf "<huge string>")
| Oval_list tl ->
fprintf ppf "@[<1>[%a]@]" (print_tree_list print_tree_1 ",") tl
| Oval_array tl ->
fprintf ppf "@[<2>[|%a|]@]" (print_tree_list print_tree_1 ",") tl
| Oval_constr (name, []) -> print_ident ppf name
| Oval_variant (name, None) -> fprintf ppf "`%s" name
| Oval_stuff s -> pp_print_string ppf s
| Oval_record fel ->
fprintf ppf "@[<1>{%a}@]" (cautious (print_fields true)) fel
| Oval_ellipsis -> raise Ellipsis
| Oval_printer f -> f ppf
| Oval_tuple tree_list ->
fprintf ppf "@[<1>(%a)@]" (print_tree_list print_tree_1 ",") tree_list
| tree -> fprintf ppf "@[<1>(%a)@]" (cautious print_tree_1) tree
and print_fields first ppf = function
| [] -> ()
| (name, tree) :: fields ->
if not first then fprintf ppf ",@ ";
fprintf ppf "@[<1>%a:@ %a@]" print_ident name (cautious print_tree_1) tree;
print_fields false ppf fields
and print_tree_list print_item sep ppf tree_list =
let rec print_list first ppf = function
| [] -> ()
| tree :: tree_list ->
if not first then fprintf ppf "%s@ " sep;
print_item ppf tree;
print_list false ppf tree_list
in
cautious (print_list true) ppf tree_list
in
cautious print_tree_1 ppf tree
(* Types *)
let rec print_list_init pr sep ppf = function
| [] -> ()
| a :: l ->
sep ppf;
pr ppf a;
print_list_init pr sep ppf l
let rec print_list pr sep ppf = function
| [] -> ()
| [ a ] -> pr ppf a
| a :: l ->
pr ppf a;
sep ppf;
print_list pr sep ppf l
let pr_present =
print_list (fun ppf s -> fprintf ppf "`%s" s) (fun ppf -> fprintf ppf "@ ")
let pr_vars =
print_list (fun ppf s -> fprintf ppf "'%s" s) (fun ppf -> fprintf ppf "@ ")
let get_label lbl =
if lbl = ""
then Reason_ast.Asttypes.Nolabel
else if String.get lbl 0 = '?'
then Optional (String.sub lbl ~pos:1 ~len:(String.length lbl - 1))
else Labelled lbl
let get_arg_suffix ppf lab =
match get_label lab with
| Nolabel -> ""
| Labelled lab ->
pp_print_string ppf "~";
pp_print_string ppf lab;
pp_print_string ppf ": ";
""
| Optional lab ->
pp_print_string ppf "~";
pp_print_string ppf lab;
pp_print_string ppf ": ";
"=?"
let rec print_out_type ppf = function
| Otyp_alias (ty, s) -> fprintf ppf "@[%a@ as '%s@]" print_out_type ty s
| Otyp_poly (sl, ty) ->
fprintf ppf "@[<hov 2>%a.@ %a@]" pr_vars sl print_out_type ty
| ty -> print_out_type_1 ~uncurried:false ppf ty
and print_arg ppf (lab, typ) =
let suffix = get_arg_suffix ppf lab in
print_out_type_2 ppf typ;
pp_print_string ppf suffix
and print_out_type_1 ~uncurried ppf = function
| Otyp_arrow _ as x ->
let rec collect_args acc typ =
match typ with
| Otyp_arrow (lbl, ty1, ty2) -> collect_args ((lbl, ty1) :: acc) ty2
| _ -> List.rev acc, typ
in
pp_open_box ppf 0;
let args, result = collect_args [] x in
let should_wrap_with_parens =
(* uncurried arguments are always wrapped in parens *)
if uncurried
then true
else
match args with
| [ (_, Otyp_tuple _) ] -> true
| [ (_, Otyp_arrow _) ] -> true
(* single argument should not be wrapped *)
| [ ("", _) ] -> false
| _ -> true
in
if should_wrap_with_parens then pp_print_string ppf "(";
if uncurried then fprintf ppf ".@ ";
print_list print_arg (fun ppf -> fprintf ppf ",@ ") ppf args;
if should_wrap_with_parens then pp_print_string ppf ")";
pp_print_string ppf " =>";
pp_print_space ppf ();
print_out_type_1 ~uncurried ppf result;
pp_close_box ppf ()
| ty -> print_out_type_2 ppf ty
and print_out_type_2 ppf = function
| Otyp_tuple tyl ->
fprintf ppf "@[<0>(%a)@]" (print_typlist print_simple_out_type ",") tyl
| ty -> print_simple_out_type ppf ty
and print_simple_out_type ppf = function
| Otyp_class (ng, id, tyl) ->
fprintf
ppf
"@[%s#%a%a@]"
(if ng then "_" else "")
print_ident
id
print_typargs
tyl
(* Melange-specific external. See the manual for the usage of [@bs]. This
[@bs] is processed into a type that looks like `Js.Internal.fn ...`. This
leaks during error reporting, where the type is printed. Here, we print it
back from `Js.Internal.fn([ `Arity_2 ('c, 'd) ], 'e)` into `('a => 'b =>
int) [@bs]` *)
(* same for `Js.Internal.fn(...)`. Either might shown *)
| Otyp_constr
( (Oide_dot
( ( Oide_dot (Oide_ident { printed_name = "Js" }, "Internal")
| Oide_ident { printed_name = "Js_internal" } )
, (("fn" | "meth") as name) ) as id)
, ([ Otyp_variant (_, Ovar_fields [ (variant, _, tys) ], _, _); result ]
as tyl) ) ->
(* Otyp_arrow *)
let make tys result =
if tys = []
then
Otyp_arrow
("", Otyp_constr (Oide_ident { printed_name = "unit" }, []), result)
else
match tys with
| [ (Otyp_tuple tys as single) ] ->
if variant = "Arity_1"
then Otyp_arrow ("", single, result)
else
List.fold_right
~f:(fun x acc -> Otyp_arrow ("", x, acc))
tys
~init:result
| [ single ] -> Otyp_arrow ("", single, result)
| _ -> raise_notrace Not_found
in
(match make tys result with
| exception _ ->
pp_open_box ppf 0;
print_typargs ppf tyl;
print_ident ppf id;
pp_close_box ppf ()
| res ->
(match name with
| "fn" -> print_out_type_1 ~uncurried:true ppf res
| "meth" ->
fprintf
ppf
"@[<0>(%a)@ [@mel.meth]@]"
(print_out_type_1 ~uncurried:false)
res
| _ -> assert false))
(* also Melange-specific. See the comment in the previous pattern *)
| Otyp_constr
( (Oide_dot
( ( Oide_dot (Oide_ident { printed_name = "Js" }, "Internal")
| Oide_ident { printed_name = "Js_internal" } )
, "meth_callback" ) as id)
, ([ Otyp_variant (_, Ovar_fields [ (variant, _, tys) ], _, _); result ]
as tyl) ) ->
let make tys result =
match tys with
| [ (Otyp_tuple tys as single) ] ->
if variant = "Arity_1"
then Otyp_arrow ("", single, result)
else
List.fold_right
~f:(fun x acc -> Otyp_arrow ("", x, acc))
tys
~init:result
| [ single ] -> Otyp_arrow ("", single, result)
| _ -> raise_notrace Not_found
in
(match make tys result with
| exception _ ->
pp_open_box ppf 0;
print_typargs ppf tyl;
print_ident ppf id;
pp_close_box ppf ()
| res ->
fprintf
ppf
"@[<0>(%a)@ [@mel.this]@]"
(print_out_type_1 ~uncurried:false)
res)
(* also Melange-specific. Turns Js.t({. foo: bar}) into {. "foo": bar} *)
| Otyp_constr
( Oide_dot (Oide_ident { printed_name = "Js" }, "t")
, [ Otyp_object (fields, rest) ] ) ->
let dot =
match rest with
| Some non_gen -> (if non_gen then "_" else "") ^ ".."
| None -> "."
in
fprintf
ppf
"@[<2>{%s %a}@]"
dot
(print_object_fields ~quote_fields:true)
fields
| Otyp_constr (id, tyl) ->
pp_open_box ppf 0;
print_ident ppf id;
(match tyl with [] -> () | _ -> print_typargs ppf tyl);
pp_close_box ppf ()
| Otyp_object (fields, rest) ->
let dot =
match rest with
| Some non_gen -> (if non_gen then "_" else "") ^ ".."
| None -> "."
in
fprintf
ppf
"@[<2>{%s %a}@]"
dot
(print_object_fields ~quote_fields:false)
fields
| Otyp_stuff s -> pp_print_string ppf s
| Otyp_var (ng, s) -> fprintf ppf "'%s%s" (if ng then "_" else "") s
| Otyp_variant (non_gen, row_fields, closed, tags) ->
let print_present ppf = function
| None | Some [] -> ()
| Some l -> fprintf ppf "@;<1 -2>> @[<hov>%a@]" pr_present l
in
let print_fields ppf = function
| Ovar_fields fields ->
print_list
print_row_field
(fun ppf -> fprintf ppf "@;<1 -2>| ")
ppf
fields
| Ovar_typ typ -> print_simple_out_type ppf typ
in
fprintf
ppf
"%s[%s@[<hv>@[<hv>%a@]%a ]@]"
(if non_gen then "_" else "")
(if closed
then if tags = None then " " else "< "
else if tags = None
then "> "
else "? ")
print_fields
row_fields
print_present
tags
| (Otyp_alias _ | Otyp_poly _) as ty ->
fprintf ppf "@[<1>(%a)@]" print_out_type ty
| (Otyp_tuple _ | Otyp_arrow _) as ty ->
(* no parentheses needed; the callsites already wrap these *)
fprintf ppf "@[<1>%a@]" print_out_type ty
| Otyp_abstract | Otyp_open | Otyp_sum _ | Otyp_record _ | Otyp_manifest (_, _)
->
()
| Otyp_module (p, ntyls) ->
fprintf ppf "@[<1>(module %a" print_ident p;
let first = ref true in
List.iter
~f:(fun (s, t) ->
let sep =
if !first
then (
first := false;
"with")
else "and"
in
fprintf ppf " %s type %s = %a" sep s print_out_type t)
ntyls;
fprintf ppf ")@]"
| Otyp_attribute (t, attr) ->
fprintf ppf "@[<1>(%a [@@%s])@]" print_out_type t attr.oattr_name
and print_object_fields ~quote_fields ppf = function
| [] -> ()
| [ (field, typ) ] ->
let field = if quote_fields then "\"" ^ field ^ "\"" else field in
fprintf ppf "%s: %a" field print_out_type typ;
(print_object_fields ~quote_fields) ppf []
| (field, typ) :: rest ->
let field = if quote_fields then "\"" ^ field ^ "\"" else field in
fprintf
ppf
"%s: %a,@ %a"
field
print_out_type
typ
(print_object_fields ~quote_fields)
rest
and print_row_field ppf (l, opt_amp, tyl) =
let pr_of ppf = if opt_amp then fprintf ppf " &@ " else fprintf ppf "" in
let parens =
match tyl with
| [ Otyp_tuple _ ] -> false (* tuples already have parentheses *)
(* [< `Ok(string & int) ] ----> string & int
* [< `Ok(string) ] -----> string *)
| _ :: _ -> true
| _ -> false
in
fprintf
ppf
"@[<hv 2>`%s%t%s%a%s@]"
l
pr_of
(if parens then "(" else "")
(print_typlist print_out_type " &")
tyl
(if parens then ")" else "")
and print_typlist print_elem sep ppf = function
| [] -> ()
| [ ty ] -> print_elem ppf ty
| ty :: tyl ->
print_elem ppf ty;
pp_print_string ppf sep;
pp_print_space ppf ();
print_typlist print_elem sep ppf tyl
and print_out_wrap_type ppf = function
| Otyp_constr (_, _ :: _) as ty -> print_out_type ppf ty
| ty -> print_simple_out_type ppf ty
and print_typargs ppf = function
| [] -> ()
| [ ty1 ] ->
pp_print_string ppf "(";
print_out_wrap_type ppf ty1;
pp_print_string ppf ")"
| tyl ->
pp_print_string ppf "(";
pp_open_box ppf 1;
print_typlist print_out_wrap_type "," ppf tyl;
pp_close_box ppf ();
pp_print_string ppf ")"
let out_type = ref print_out_type
let variance = function
| Reason_omp.Ast_414.Asttypes.NoVariance -> ""
| Covariant -> "+"
| Contravariant -> "-"
let type_parameter ppf (ty, (var, _)) =
fprintf ppf "%s%s" (variance var) (if ty = "_" then ty else "'" ^ ty)
let print_out_class_params ppf = function
| [] -> ()
| tyl ->
fprintf
ppf
"(@[<1>%a@])@ "
(print_list type_parameter (fun ppf -> fprintf ppf ",@ "))
tyl
let rec print_out_class_type ppf = function
| Octy_constr (id, tyl) ->
let pr_tyl ppf = function
| [] -> ()
| tyl ->
fprintf ppf "@[<1> %a@]" (print_typlist print_out_wrap_type "") tyl
in
fprintf ppf "@[%a%a@]" print_ident id pr_tyl tyl
| Octy_arrow (lab, argument_type, return_class_type) ->
(* class arrow types need to be printed differently. For one, you can't do:
class a: a => b
because due to existing parsing issues, the `a` neds to be wrapped in
parens (unlike normal arrow types). We can change this logic once this is
no longer true *)
let rec print_class_type_arguments_that_might_be_arrow ppf = function
| Otyp_arrow ("", typ1, typ2) ->
fprintf
ppf
"@[%a,@ %a@]"
print_out_type
typ1
print_class_type_arguments_that_might_be_arrow
typ2
| Otyp_arrow (_, typ1, typ2) ->
fprintf
ppf
"@[~%s: %a,@ %a@]"
lab
print_out_type
typ1
print_class_type_arguments_that_might_be_arrow
typ2
| argument_not_arrow -> fprintf ppf "%a" print_out_type argument_not_arrow
in
fprintf
ppf
"@[(%a) =>@ %a@]"
print_class_type_arguments_that_might_be_arrow
argument_type
print_out_class_type
return_class_type
| Octy_signature (self_ty, csil) ->
let pr_param ppf = function
| Some ty -> fprintf ppf "@ @[(%a)@]" print_out_type ty
| None -> ()
in
fprintf
ppf
"@[<hv 2>@[<2>{%a@]@ %a@;<1 -2>}@]"
pr_param
self_ty
(print_list print_out_class_sig_item (fun ppf -> fprintf ppf ";@ "))
csil
and print_out_class_sig_item ppf = function
| Ocsg_constraint (ty1, ty2) ->
fprintf ppf "@[<2>as %a =@ %a@]" print_out_type ty1 print_out_type ty2
| Ocsg_method (name, priv, virt, ty) ->
fprintf
ppf
"@[<2>%s%s%s:@ %a@]"
(if priv then "pri " else "pub ")
(if virt then "virtual " else "")
name
print_out_type
ty
| Ocsg_value (name, mut, vr, ty) ->
fprintf
ppf
"@[<2>val %s%s%s:@ %a@]"
(if mut then "mutable " else "")
(if vr then "virtual " else "")
name
print_out_type
ty
(* Signature *)
let is_rec_next = function
| Osig_class (_, _, _, _, Orec_next) :: _
| Osig_class_type (_, _, _, _, Orec_next) :: _
| Osig_module (_, _, Orec_next) :: _
| Osig_type (_, Orec_next) :: _ ->
true
| _ -> false
let rec print_out_functor ppf = function
| Omty_functor (None, mty_res) ->
fprintf ppf "() %a" print_out_functor mty_res
| Omty_functor (Some (name, mty_arg), mty_res) ->
let name = match name with None -> "_" | Some name -> name in
fprintf
ppf
"(%s : %a) => %a"
name
print_out_module_type
mty_arg
print_out_functor
mty_res
| m -> fprintf ppf "%a" print_out_module_type m
and print_out_module_type ppf = function
| Omty_abstract -> ()
| Omty_functor _ as t -> fprintf ppf "@[<2>%a@]" print_out_functor t
| Omty_ident id -> fprintf ppf "%a" print_ident id
| Omty_signature sg ->
fprintf ppf "@[<hv 2>{@ %a@;<1 -2>}@]" print_out_signature sg
| Omty_alias id -> fprintf ppf "(module %a)" print_ident id
and print_out_signature ppf = function
| [] -> ()
| [ item ] -> fprintf ppf "%a;" print_out_sig_item item
| Osig_typext (ext, Oext_first) :: items ->
(* Gather together the extension constructors *)
let rec gather_extensions acc items =
match items with
| Osig_typext (ext, Oext_next) :: items ->
gather_extensions
({ ocstr_name = ext.oext_name
; ocstr_args = ext.oext_args
; ocstr_return_type = ext.oext_ret_type
}
:: acc)
items
| _ -> List.rev acc, items
in
let exts, items =
gather_extensions
[ { ocstr_name = ext.oext_name
; ocstr_args = ext.oext_args
; ocstr_return_type = ext.oext_ret_type
}
]
items
in
let te =
{ otyext_name = ext.oext_type_name
; otyext_params = ext.oext_type_params
; otyext_constructors = exts
; otyext_private = ext.oext_private
}
in
let sep = if is_rec_next items then "" else ";" in
fprintf
ppf
"%a%s@ %a"
print_out_type_extension
te
sep
print_out_signature
items
| item :: items ->
let sep = if is_rec_next items then "" else ";" in
fprintf ppf "%a%s@ %a" print_out_sig_item item sep print_out_signature items
and print_out_sig_item ppf = function
| Osig_class (vir_flag, name, params, clt, rs) ->
fprintf
ppf
"@[<2>%s%s@ %s %a@,:@ %a@]"
(if rs = Orec_next then "and" else "class")
(if vir_flag then " virtual" else "")
name
print_out_class_params
params
print_out_class_type
clt
| Osig_class_type (vir_flag, name, params, clt, rs) ->
fprintf
ppf
"@[<2>%s%s@ %s %a@,=@ %a@]"
(if rs = Orec_next then "and" else "class type")
(if vir_flag then " virtual" else "")
name
print_out_class_params
params
print_out_class_type
clt
| Osig_typext (ext, Oext_exception) ->
fprintf
ppf
"@[<2>exception %a@]"
print_out_constr
{ ocstr_name = ext.oext_name
; ocstr_args = ext.oext_args
; ocstr_return_type = ext.oext_ret_type
}
| Osig_typext (ext, _) -> print_out_extension_constructor ppf ext
| Osig_modtype (name, Omty_abstract) ->
fprintf ppf "@[<2>module type %s@]" name
| Osig_modtype (name, mty) ->
fprintf ppf "@[<2>module type %s =@ %a@]" name print_out_module_type mty
| Osig_module (name, Omty_alias id, _) ->
fprintf ppf "@[<2>module %s =@ %a@]" name print_ident id
| Osig_module (name, mty, rs) ->
fprintf
ppf
"@[<2>%s %s:@ %a@]"
(match rs with
| Orec_not -> "module"
| Orec_first -> "module rec"
| Orec_next -> "and")
name
print_out_module_type
mty
| Osig_type (td, rs) ->
print_out_type_decl
(match rs with
| Orec_not -> "type nonrec"
| Orec_first -> "type"
| Orec_next -> "and")
ppf
td
| Osig_ellipsis -> fprintf ppf "..."
| Osig_value { oval_name; oval_type; oval_prims; oval_attributes } ->
let printAttributes ppf =
List.iter ~f:(fun a -> fprintf ppf "[@@%s]" a.oattr_name)
in
let keyword = if oval_prims = [] then "let" else "external" in
let hackyMelangeExternalAnnotation, rhsValues =
List.partition
~f:(fun item ->
(* "MEL:" is considered as a Melange external annotation,
`[@mel.module]` and the sort.
"What's going on here? Isn't [@mel.foo] supposed to be an attribute
in oval_attributes?" Usually yes. But here, we're intercepting
things a little too late. Melange already finished its
pre/post-processing work before we get to print anything. The
original attribute is already gone, replaced by a "BS:asdfasdfasd"
thing here. *)
String.length item >= 4
&& item.[0] = 'M'
&& item.[1] = 'E'
&& item.[1] = 'L'
&& item.[3] = ':')
oval_prims
in
let print_right_hand_side ppf = function
| [] -> ()
| s :: sl ->
fprintf ppf "@ = \"%s\"" s;
List.iter ~f:(fun s -> fprintf ppf "@ \"%s\"" s) sl
in
fprintf
ppf
"@[<2>%a%a%s %a:@ %a%a@]"
(fun ppf -> List.iter ~f:(fun _ -> fprintf ppf "[@@mel...]@ "))
hackyMelangeExternalAnnotation
printAttributes
oval_attributes
keyword
value_ident
oval_name
!out_type
oval_type
print_right_hand_side
rhsValues
and print_out_type_decl kwd ppf td =
let print_constraints ppf =
List.iter
~f:(fun (ty1, ty2) ->
fprintf
ppf
"@ @[<2>constraint %a =@ %a@]"
print_out_type
ty1
print_out_type
ty2)
td.otype_cstrs
in
let type_defined ppf =
match td.otype_params with
| [] -> pp_print_string ppf td.otype_name
| [ param ] -> fprintf ppf "@[%s(%a)@]" td.otype_name type_parameter param
| _ ->
fprintf
ppf
"@[%s(@[%a@])@]"
td.otype_name
(print_list type_parameter (fun ppf -> fprintf ppf ",@ "))
td.otype_params
in
let print_manifest ppf = function
| Otyp_manifest (ty, _) -> fprintf ppf " =@ %a" print_out_type ty
| _ -> ()
in
let print_name_params ppf =
fprintf ppf "%s %t%a" kwd type_defined print_manifest td.otype_type
in
let ty =
match td.otype_type with Otyp_manifest (_, ty) -> ty | _ -> td.otype_type
in
let print_private ppf = function
| Reason_omp.Ast_414.Asttypes.Private -> fprintf ppf " pri"
| Public -> ()
in
let print_out_tkind ppf = function
| Otyp_abstract -> ()
| Otyp_record lbls ->
fprintf
ppf
" =%a {%a@;<1 -2>}"
print_private
td.otype_private
(print_list_init print_out_label (fun ppf -> fprintf ppf "@ "))
lbls
| Otyp_sum constrs ->
fprintf
ppf
" =%a@;<1 2>%a"
print_private
td.otype_private
(print_list print_out_constr (fun ppf -> fprintf ppf "@ | "))
constrs
| Otyp_open -> fprintf ppf " = .."
| ty ->
fprintf
ppf
" =%a@;<1 2>%a"
print_private
td.otype_private
print_out_type
ty
in
fprintf
ppf
"@[<2>@[<hv 2>%t%a@]%t@]"
print_name_params
print_out_tkind
ty
print_constraints
and print_out_constr
ppf
{ ocstr_name = name; ocstr_args = tyl; ocstr_return_type = ret_type_opt }
=
match ret_type_opt with
| None ->
(match tyl with
| [] -> pp_print_string ppf name
| [ Otyp_record lbls ] ->
fprintf
ppf
"@[<2>%s({%a@;<1 -2>})@]"
name
(print_list_init print_out_label (fun ppf -> fprintf ppf "@ "))
lbls
| _ ->
fprintf
ppf
"@[<2>%s(%a)@]"
name
(print_typlist print_simple_out_type ",")
tyl)
| Some ret_type ->
(match tyl with
| [] -> fprintf ppf "@[<2>%s:@ %a@]" name print_simple_out_type ret_type
| [ Otyp_record lbls ] ->
fprintf
ppf
"@[<2>%s({%a@;<1 -2>}): %a@]"
name
(print_list_init print_out_label (fun ppf -> fprintf ppf "@ "))
lbls
print_simple_out_type
ret_type
| _ ->
fprintf
ppf
"@[<2>%s(%a): %a@]"
name
(print_typlist print_simple_out_type ",")
tyl
print_simple_out_type
ret_type)
and print_out_label ppf (name, mut, arg) =
fprintf
ppf
"@[<2>%s%s:@ %a@],"
(if mut then "mutable " else "")
name
print_out_type
arg
and print_out_extension_constructor ppf ext =
let print_extended_type ppf =
let print_type_parameter ppf ty =
fprintf ppf "%s" (if ty = "_" then ty else "'" ^ ty)
in
match ext.oext_type_params with
| [] -> fprintf ppf "%s" ext.oext_type_name
| [ ty_param ] ->
fprintf ppf "@[%a@ %s@]" print_type_parameter ty_param ext.oext_type_name
| _ ->
fprintf
ppf
"@[(@[%a)@]@ %s@]"
(print_list print_type_parameter (fun ppf -> fprintf ppf ",@ "))
ext.oext_type_params
ext.oext_type_name
in
fprintf
ppf
"@[<hv 2>type %t +=%s@;<1 2>%a@]"
print_extended_type
(if ext.oext_private = Reason_omp.Ast_414.Asttypes.Private
then " pri"
else "")
print_out_constr
{ ocstr_name = ext.oext_name
; ocstr_args = ext.oext_args
; ocstr_return_type = ext.oext_ret_type
}
and print_out_type_extension ppf te =
let print_extended_type ppf =
let print_type_parameter ppf ty =
fprintf ppf "%s" (if ty = "_" then ty else "'" ^ ty)
in
match te.otyext_params with
| [] -> fprintf ppf "%s" te.otyext_name
| [ param ] ->
fprintf ppf "@[%a@ %s@]" print_type_parameter param te.otyext_name
| _ ->
fprintf
ppf
"@[(@[%a)@]@ %s@]"
(print_list print_type_parameter (fun ppf -> fprintf ppf ",@ "))
te.otyext_params
te.otyext_name
in
fprintf
ppf
"@[<hv 2>type %t +=%s@;<1 2>%a@]"
print_extended_type
(if te.otyext_private = Reason_omp.Ast_414.Asttypes.Private
then " pri"
else "")
(print_list print_out_constr (fun ppf -> fprintf ppf "@ | "))
te.otyext_constructors
(* Phrases *)
let print_out_exception ppf exn outv =
match exn with
| Sys.Break -> fprintf ppf "Interrupted.@."
| Out_of_memory -> fprintf ppf "Out of memory during evaluation.@."
| Stack_overflow ->
fprintf ppf "Stack overflow during evaluation (looping recursion?).@."
| _ -> fprintf ppf "@[Exception:@ %a.@]@." print_out_value outv
let rec print_items ppf = function
| [] -> ()
| (Osig_typext (ext, Oext_first), None) :: items ->
(* Gather together extension constructors *)
let rec gather_extensions acc items =
match items with
| (Osig_typext (ext, Oext_next), None) :: items ->
gather_extensions
({ ocstr_name = ext.oext_name
; ocstr_args = ext.oext_args
; ocstr_return_type = ext.oext_ret_type
}
:: acc)
items
| _ -> List.rev acc, items
in
let exts, items =
gather_extensions
[ { ocstr_name = ext.oext_name
; ocstr_args = ext.oext_args
; ocstr_return_type = ext.oext_ret_type
}
]
items
in
let te =
{ otyext_name = ext.oext_type_name
; otyext_params = ext.oext_type_params
; otyext_constructors = exts
; otyext_private = ext.oext_private
}
in
fprintf ppf "@[%a@]" print_out_type_extension te;
if items <> [] then fprintf ppf "@ %a" print_items items
| (tree, valopt) :: items ->
(match valopt with
| Some v ->
fprintf ppf "@[<2>%a =@ %a;@]" print_out_sig_item tree print_out_value v
| None -> fprintf ppf "@[%a;@]" print_out_sig_item tree);
if items <> [] then fprintf ppf "@ %a" print_items items
let print_out_phrase ppf = function
| Ophr_eval (outv, ty) ->
fprintf ppf "@[- : %a@ =@ %a@]@." print_out_type ty print_out_value outv
| Ophr_signature [] -> ()
| Ophr_signature items -> fprintf ppf "@[<v>%a@]@." print_items items
| Ophr_exception (exn, outv) -> print_out_exception ppf exn outv
================================================
FILE: src/reason-parser/reason_oprint.mli
================================================
open Format
open Reason_omp.Ast_414.Outcometree
val print_ident : formatter -> out_ident -> unit
val print_out_value : formatter -> out_value -> unit
val print_out_label : formatter -> string * bool * out_type -> unit
val print_out_type : formatter -> out_type -> unit
val print_out_constr : formatter -> out_constructor -> unit
val print_out_class_type : formatter -> out_class_type -> unit
val print_out_module_type : formatter -> out_module_type -> unit
val print_out_sig_item : formatter -> out_sig_item -> unit
val print_out_signature : formatter -> out_sig_item list -> unit
val print_out_type_extension : formatter -> out_type_extension -> unit
val print_out_phrase : formatter -> out_phrase -> unit
val parenthesized_ident : string -> bool
================================================
FILE: src/reason-parser/reason_parser.mly
================================================
(*
* Copyright (c) 2015-present, Facebook, Inc.
*
* This source code is licensed under the MIT license found in the
* LICENSE file in the root directory of this source tree.
*
* Forked from OCaml, which is provided under the license below:
*
* Xavier Leroy, projet Cristal, INRIA Rocquencourt
*
* Copyright © 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006 Inria
*
* Permission is hereby granted, free of charge, to the Licensee obtaining a
* copy of this software and associated documentation files (the "Software"),
* to deal in the Software without restriction, including without limitation
* the rights to use, copy, modify, merge, publish, distribute, sublicense
* under any license of the Licensee's choice, and/or sell copies of the
* Software, subject to the following conditions:
*
* 1. Redistributions of source code must retain the above copyright notice
* and the following disclaimer.
* 2. Redistributions in binary form must reproduce the above copyright
* notice, the following disclaimer in the documentation and/or other
* materials provided with the distribution.
* 3. All advertising materials mentioning features or use of the Software
* must display the following acknowledgement: This product includes all or
* parts of the Caml system developed by Inria and its contributors.
* 4. Other than specified in clause 3, neither the name of Inria nor the
* names of its contributors may be used to endorse or promote products
* derived from the Software without specific prior written permission.
*
* Disclaimer
*
* This software is provided by Inria and contributors “as is” and any express
* or implied warranties, including, but not limited to, the implied
* warranties of merchantability and fitness for a particular purpose are
* disclaimed. in no event shall Inria or its contributors be liable for any
* direct, indirect, incidental, special, exemplary, or consequential damages
* (including, but not limited to, procurement of substitute goods or
* services; loss of use, data, or profits; or business interruption) however
* caused and on any theory of liability, whether in contract, strict
* liability, or tort (including negligence or otherwise) arising in any way
* out of the use of this software, even if advised of the possibility of such
* damage.
*
*)
(* The parser definition *)
%{
module Ast_helper = Ppxlib.Ast_helper
module Location = Ppxlib.Location
open Ppxlib.Asttypes
let mkloc txt loc =
{ Location.txt; loc }
let mknoloc txt = mkloc txt Location.none
let raise_error error loc =
Reason_errors.raise_error (Ast_error error) loc
module Clflags = Reason_syntax_util.Clflags
(*
TODO:
- Remove all [open]s from the top of this file one by one and fix compilation
failures that ensue by specifying the appropriate long identifiers. That
will make the parser much easier to reason about.
- Go back to trunk, do the same (remove [open]s, and fully specify long
idents), to perform a clean diff.
*)
(**
location.ml:
------------
let mkloc txt loc = { txt ; loc }
let rhs_loc n = {
loc_start = Parsing.rhs_start_pos n;
loc_end = Parsing.rhs_end_pos n;
loc_ghost = false;
}
let symbol_rloc () = {
loc_start = Parsing.symbol_start_pos ();
loc_end = Parsing.symbol_end_pos ();
loc_ghost = false;
}
let symbol_gloc () = {
loc_start = Parsing.symbol_start_pos ();
loc_end = Parsing.symbol_end_pos ();
loc_ghost = true;
}
ast_helper.ml:
------------
module Typ = struct
val mk: ?loc:loc -> ?attrs:attrs -> core_type_desc -> core_type
let mk ?(loc = !default_loc) ?(attrs = []) d =
{ptyp_desc = d; ptyp_loc = loc; ptyp_attributes = attrs}
..
end
parse_tree.mli
--------------
and core_type = {
ptyp_desc: core_type_desc;
ptyp_loc: Location.t;
ptyp_attributes: attributes; (* ... [@id1] [@id2] *)
}
and core_type_desc =
| Ptyp_any
(* _ *)
| Ptyp_var of string
(* 'a *)
| Ptyp_arrow of label * core_type * core_type
(* T1 -> T2 (label = "")
~l:T1 -> T2 (label = "l")
?l:T1 -> T2 (label = "?l")
*)
| Ptyp_tuple of core_type list
(* T1 * ... * Tn (n >= 2) *)
reason_parser.mly
---------------
In general:
syntax variant {pblah_desc: core_blah_desc
pblah_loc: {txt, loc}
pblah_attributes: ... }
/ \ / \
val mkblah: ~loc -> ~attributes -> core_blah_desc -> core_blah
let mkblah = Blah.mk
*)
let make_floating_doc attr =
match attr with
| { Ppxlib.attr_name = {txt = "ocaml.doc"; _} as attr_name; _} ->
{attr with attr_name = {attr_name with txt = "ocaml.text"}}
| attr -> attr
let uncurry_payload ?(name="u") loc =
{ Ppxlib.attr_name = {loc; txt = name};
attr_payload = PStr [];
attr_loc = loc
}
let dummy_loc () = {
Location.loc_start = Lexing.dummy_pos;
loc_end = Lexing.dummy_pos;
loc_ghost = false;
}
let mklocation loc_start loc_end = {
Location.loc_start = loc_start;
loc_end = loc_end;
loc_ghost = false;
}
let make_real_loc loc =
{ loc with Location.loc_ghost = false }
let make_ghost_loc loc =
{ loc with Location.loc_ghost = true }
let ghloc ?(loc=dummy_loc ()) d =
{ Location.txt = d; loc = (make_ghost_loc loc) }
(**
* turn an object into a real
*)
let make_real_exp ({ Ppxlib.pexp_loc; _ } as exp) =
{ exp with pexp_loc = make_real_loc pexp_loc }
let make_real_pat ({ Ppxlib.ppat_loc; _ } as pat) =
{ pat with ppat_loc = make_real_loc ppat_loc }
(*
* change the location state to be a ghost location or real location
*)
let set_loc_state is_ghost loc =
if is_ghost then make_ghost_loc loc else make_real_loc loc
let mktyp ?(loc=dummy_loc()) ?(ghost=false) d =
let loc = set_loc_state ghost loc in
Ast_helper.Typ.mk ~loc d
let mkpat ?(attrs=[]) ?(loc=dummy_loc()) ?(ghost=false) d =
let loc = set_loc_state ghost loc in
Ast_helper.Pat.mk ~loc ~attrs d
let mkexp ?(attrs=[]) ?(loc=dummy_loc()) ?(ghost=false) d =
let loc = set_loc_state ghost loc in
Ast_helper.Exp.mk ~loc ~attrs d
let mkmty ?(loc=dummy_loc()) ?(ghost=false) d =
let loc = set_loc_state ghost loc in
Ast_helper.Mty.mk ~loc d
let mksig ?(loc=dummy_loc()) ?(ghost=false) d =
let loc = set_loc_state ghost loc in
Ast_helper.Sig.mk ~loc d
let mkmod ?(loc=dummy_loc()) ?(ghost=false) d =
let loc = set_loc_state ghost loc in
Ast_helper.Mod.mk ~loc d
let mkstr ?(loc=dummy_loc()) ?(ghost=false) d =
let loc = set_loc_state ghost loc in
Ast_helper.Str.mk ~loc d
let mkclass ?(loc=dummy_loc()) ?(ghost=false) d =
let loc = set_loc_state ghost loc in
Ast_helper.Cl.mk ~loc d
let mkcty ?(loc=dummy_loc()) ?(ghost=false) d =
let loc = set_loc_state ghost loc in
Ast_helper.Cty.mk ~loc d
let mkctf ?(loc=dummy_loc()) ?(ghost=false) d =
let loc = set_loc_state ghost loc in
Ast_helper.Ctf.mk ~loc d
let may_tuple startp endp = function
| [] -> assert false
| [x] -> {x with Ppxlib.pexp_loc = mklocation startp endp}
| xs -> mkexp ~loc:(mklocation startp endp) (Pexp_tuple xs)
(**
Make a core_type from a as_loc(LIDENT).
Useful for record type punning.
type props = {width: int, height: int};
type state = {nbrOfClicks: int};
type component = {props, state};
*)
let mkct { Location.txt; loc } =
let lident = Ppxlib.Longident.Lident txt in
let ttype = Ppxlib.Ptyp_constr({txt = lident; loc = loc}, []) in
{ Ppxlib.ptyp_desc = ttype
; ptyp_loc = loc
; ptyp_attributes = []
; ptyp_loc_stack =[]
}
let mkcf ?(loc=dummy_loc()) ?(ghost=false) d =
let loc = set_loc_state ghost loc in
Ast_helper.Cf.mk ~loc d
let simple_ghost_text_attr ?(loc=dummy_loc ()) txt =
let loc = set_loc_state true loc in
[{ Ppxlib.attr_name = {txt; loc};
attr_payload = PStr [];
attr_loc = loc;
}]
let mkExplicitArityTuplePat ?(loc=dummy_loc ()) pat =
(* Tell OCaml type system that what this tuple construction represents is
not actually a tuple, and should represent several constructor
arguments. This allows the syntax the ability to distinguish between:
X (10, 20) -- One argument constructor
X 10 20 -- Multi argument constructor
*)
mkpat
~loc
~attrs:(simple_ghost_text_attr ~loc "explicit_arity")
pat
let mkExplicitArityTupleExp ?(loc=dummy_loc ()) exp_desc =
mkexp
~loc
~attrs:(simple_ghost_text_attr ~loc "explicit_arity")
exp_desc
let is_pattern_list_single_any = function
| [{Ppxlib.ppat_desc=Ppat_any; ppat_attributes=[]; _} as onlyItem] ->
Some onlyItem
| _ -> None
let mkoperator { Location.txt; loc } =
Ast_helper.Exp.mk ~loc (Pexp_ident(mkloc (Ppxlib.Longident.Lident txt) loc))
(*
Ghost expressions and patterns:
expressions and patterns that do not appear explicitly in the
source file they have the loc_ghost flag set to true.
Then the profiler will not try to instrument them and the
-annot option will not try to display their type.
Every grammar rule that generates an element with a location must
make at most one non-ghost element, the topmost one.
How to tell whether your location must be ghost:
A location corresponds to a range of characters in the source file.
If the location contains a piece of code that is syntactically
valid (according to the documentation), and corresponds to the
AST node, then the location must be real; in all other cases,
it must be ghost.
jordwalke: Noticed that ghost expressions are often used when inserting
additional AST nodes from a parse rule. Either an extra wrapping one, or an
additional inner node. This is consistent with the above description, I
believe.
*)
let ghunit ?(loc=dummy_loc ()) () =
mkexp ~ghost:true ~loc (Pexp_construct (mknoloc (Ppxlib.Longident.Lident "()"), None))
let mkinfixop arg1 op arg2 =
mkexp(Pexp_apply(op, [Nolabel, arg1; Nolabel, arg2]))
let mkinfix arg1 name arg2 =
mkinfixop arg1 (mkoperator name) arg2
let neg_string f =
if String.length f > 0 && f.[0] = '-'
then String.sub f ~pos:1 ~len:(String.length f - 1)
else "-" ^ f
let mkuminus name ({ Ppxlib.pexp_desc; _ } as arg) =
match name.Location.txt, pexp_desc with
| "-", Pexp_constant(Pconst_integer (n,m)) ->
mkexp(Pexp_constant(Pconst_integer(neg_string n,m)))
| ("-" | "-."), Pexp_constant(Pconst_float (f, m)) ->
mkexp(Pexp_constant(Pconst_float(neg_string f, m)))
| txt, _ ->
let name = {name with txt = "~" ^ txt} in
mkexp(Pexp_apply(mkoperator name, [Nolabel, arg]))
let mk_functor_mod args body =
let folder { Location.txt; loc } acc =
mkmod ~loc (Pmod_functor(txt, acc))
in
List.fold_right args ~init:body ~f:folder
let mk_functor_mty args body =
let folder { Location.txt; loc } acc =
mkmty ~loc (Pmty_functor(txt, acc))
in
List.fold_right args ~init:body ~f:folder
let mkuplus name ({ Ppxlib.pexp_desc; _ } as arg) =
match name.Location.txt, pexp_desc with
| "+", Pexp_constant(Pconst_integer _)
| ("+" | "+."), Pexp_constant(Pconst_float _) ->
mkexp arg.pexp_desc
| txt, _ ->
let name = {name with txt = "~" ^ txt} in
mkexp(Pexp_apply(mkoperator name, [Nolabel, arg]))
let mkexp_cons consloc args loc =
mkexp ~loc (Pexp_construct(mkloc (Ppxlib.Longident.Lident "::") consloc, Some args))
let mkexp_constructor_unit ?(uncurried=false) consloc loc =
let attrs = if uncurried then [uncurry_payload ~name:"uncurry" loc] else [] in
mkexp ~attrs ~loc (Pexp_construct(mkloc (Ppxlib.Longident.Lident "()") consloc, None))
let ghexp_cons args loc =
mkexp ~ghost:true ~loc (Pexp_construct(mkloc (Ppxlib.Longident.Lident "::") loc, Some args))
let mkpat_cons args loc =
mkpat ~loc (Ppat_construct(mkloc (Ppxlib.Longident.Lident "::") loc, Some ([], args)))
let ghpat_cons args loc =
mkpat ~ghost:true ~loc (Ppat_construct(mkloc (Ppxlib.Longident.Lident "::") loc, Some ([], args)))
let mkpat_constructor_unit consloc loc =
mkpat ~loc (Ppat_construct(mkloc (Ppxlib.Longident.Lident "()") consloc, None))
let simple_pattern_list_to_tuple ?(loc=dummy_loc ()) = function
| [] -> assert false
| lst -> mkpat ~loc (Ppat_tuple lst)
let mktailexp_extension loc seq ext_opt =
let rec handle_seq = function
| [] ->
let base_case = match ext_opt with
| Some ext ->
ext
| None ->
let loc = make_ghost_loc loc in
let nil = { Location.txt = Ppxlib.Longident.Lident "[]"; loc } in
Ast_helper.Exp.mk ~loc (Pexp_construct (nil, None)) in
base_case
| (e1: Ppxlib.expression) :: el ->
let exp_el = handle_seq el in
let loc = mklocation e1.pexp_loc.loc_start exp_el.pexp_loc.loc_end in
let arg = mkexp ~ghost:true ~loc (Pexp_tuple [e1; exp_el]) in
ghexp_cons arg loc
in
handle_seq seq
let mktailpat_extension loc (seq, ext_opt) =
let rec handle_seq = function
[] ->
let base_case = match ext_opt with
| Some ext ->
ext
| None ->
let loc = make_ghost_loc loc in
let nil = { Location.txt = Ppxlib.Longident.Lident "[]"; loc } in
mkpat ~loc (Ppat_construct (nil, None)) in
base_case
| (p1: Ppxlib.pattern) :: pl ->
let pat_pl = handle_seq pl in
let loc = mklocation p1.ppat_loc.loc_start pat_pl.ppat_loc.loc_end in
let arg = mkpat ~ghost:true ~loc (Ppat_tuple [p1; pat_pl]) in
ghpat_cons arg loc in
handle_seq seq
let makeFrag loc (body: Ppxlib.expression) =
let attribute = {
Ppxlib.attr_name = { Location.txt = "JSX"; loc };
attr_payload = PStr [];
attr_loc = loc
}
in
{ body with pexp_attributes = attribute :: body.pexp_attributes }
(* Applies attributes to the structure item, not the expression itself. Makes
* structure item have same location as expression. *)
let mkstrexp ?loc e attrs =
let loc = match loc with None -> e.Ppxlib.pexp_loc | Some loc -> loc in
let e = { e with pexp_loc = loc } in
{ Ppxlib.pstr_desc = Pstr_eval (e, attrs); pstr_loc = e.pexp_loc }
let ghexp_constraint loc e (t1, t2) =
match t1, t2 with
| Some t, None -> mkexp ~ghost:true ~loc (Pexp_constraint(e, t))
| _, Some t -> mkexp ~ghost:true ~loc (Pexp_coerce(e, t1, t))
| None, None -> assert false
let mk_record_expr ?loc (exten, fields) =
match fields, exten with
| [], Some expr -> expr
| _ -> mkexp ?loc (Pexp_record (fields, exten))
let array_function ?(loc=dummy_loc()) str name =
ghloc ~loc (Ppxlib.Longident.Ldot(Lident str, (if !Clflags.unsafe then "unsafe_" ^ name else name)))
let syntax_error loc s =
raise_error (Other_syntax_error s) loc
let syntax_error_exp loc msg =
Ast_helper.Exp.extension ~loc (Reason_errors.error_extension_node loc msg)
let syntax_error_pat loc msg =
Ast_helper.Pat.extension ~loc (Reason_errors.error_extension_node loc msg)
let syntax_error_mty loc msg =
Ast_helper.Mty.extension ~loc (Reason_errors.error_extension_node loc msg)
let syntax_error_typ loc msg =
Ast_helper.Typ.extension ~loc (Reason_errors.error_extension_node loc msg)
let not_expecting start_pos end_pos nonterm =
let location = mklocation start_pos end_pos in
raise_error (Not_expecting (location, nonterm)) location
(* Taken from the OCaml compiler. The next comment is also present there.
This is somewhat hackish: we don't want to allow "type nonrec t := ...",
because the definition is nonrecursive by default. Simply removing
"nonrec_flag" from the rule results in a shift/reduce conflict:
"TYPE . UNDERSCORE"
can either be a shift in the type_subst_declaration rule, or a reduce of
nonrec_flag in the type_declaration rule.
To avoid it we could either %inline the nonrec_flag rule, but "meh", or we
could add nonrec_flag to the type_subst_declaration rule, and explicitely
check if it was passed. In which case we raise a proper error. *)
let check_nonrec_absent loc nonrec_flag =
match nonrec_flag with
| Recursive ->
() (* nothing to do, this happens when "nonrec" is absent from the source *)
| Nonrecursive ->
let err = {|"nonrec", type substitutions are non recursive by default|} in
raise Syntaxerr.(Error(Not_expecting(loc, err)))
let mkexp_fun {Location.txt; loc} (body: Ppxlib.expression) =
let loc = mklocation loc.loc_start body.pexp_loc.loc_end in
match txt with
| Reason_parser_def.Term (label, default_expr, pat) ->
Ast_helper.Exp.fun_ ~loc label default_expr pat body
| Type str ->
Ast_helper.Exp.newtype ~loc (mkloc str loc) body
let mkclass_fun {Location. txt ; loc} (body: Ppxlib.class_expr) =
let loc = mklocation loc.loc_start body.pcl_loc.loc_end in
match txt with
| Reason_parser_def.Term (label, default_expr, pat) ->
Ast_helper.Cl.fun_ ~loc label default_expr pat body
| Type _ ->
let pat = syntax_error_pat loc "(type) not allowed in classes" in
Ast_helper.Cl.fun_ ~loc Nolabel None pat body
let mktyp_arrow ({Location.txt = (label, cod); loc}, uncurried) (dom: Ppxlib.core_type) =
let loc = mklocation loc.loc_start dom.ptyp_loc.loc_end in
let typ = mktyp ~loc (Ptyp_arrow (label, cod, dom)) in
{typ with ptyp_attributes = (if uncurried then [uncurry_payload loc] else [])}
let mkcty_arrow ({Location.txt = (label, cod); loc}, uncurried) (dom: Ppxlib.class_type) =
let loc = mklocation loc.loc_start dom.pcty_loc.loc_end in
let ct = mkcty ~loc (Pcty_arrow (label, cod, dom)) in
{ct with pcty_attributes = (if uncurried then [uncurry_payload loc] else [])}
(**
* process the occurrence of _ in the arguments of a function application
* replace _ with a new variable, currently __x, in the arguments
* return a wrapping function that wraps ((__x) => ...) around an expression
* e.g. foo(_, 3) becomes (__x) => foo(__x, 3)
*)
let process_underscore_application args =
let exp_question = ref None in
let hidden_var = "__x" in
let check_arg ((lab, exp) as arg) =
match exp.Ppxlib.pexp_desc with
| Pexp_ident ({ txt = Lident "_"; _} as id) ->
let new_id = mkloc (Ppxlib.Longident.Lident hidden_var) id.loc in
let new_exp = mkexp (Pexp_ident new_id) ~loc:exp.pexp_loc in
exp_question := Some new_exp;
(lab, new_exp)
| _ ->
arg in
let args = List.map ~f:check_arg args in
let wrap exp_apply = match !exp_question with
| Some {pexp_loc=loc;_} ->
let pattern = mkpat (Ppat_var (mkloc hidden_var loc)) ~loc in
begin match exp_apply.Ppxlib.pexp_desc with
(* Transform pipe first with underscore application correct:
* 5->doStuff(3, _, 7);
* (5 |. doStuff)(3, _, 7)
* 5 |. (__x => doStuff(3, __x, 7))
*)
| Pexp_apply(
{pexp_desc= Pexp_apply(
{pexp_desc = Pexp_ident({txt = Ppxlib.Longident.Lident "|."; _}); _} as pipeExp,
[Nolabel, arg1; Nolabel, ({pexp_desc = Pexp_ident _; _} as arg2)]
(* 5 doStuff *)
); _},
args (* [3, __x, 7] *)
) ->
(* build `doStuff(3, __x, 7)` *)
let innerApply = {arg2 with pexp_desc = Pexp_apply(arg2, args)} in
(* build `__x => doStuff(3, __x, 7)` *)
let param : Ppxlib.function_param =
{ pparam_desc = Pparam_val (Nolabel, None, pattern); pparam_loc = loc }
in
let innerFun =
mkexp (Pexp_function ([param], None, Pfunction_body innerApply)) ~loc
in
(* build `5 |. (__x => doStuff(3, __x, 7))` *)
{exp_apply with pexp_desc =
Pexp_apply(pipeExp, [Nolabel, arg1; Nolabel, innerFun])
}
| _ ->
let param : Ppxlib.function_param =
{ pparam_desc = Pparam_val (Nolabel, None, pattern); pparam_loc = loc }
in
mkexp (Pexp_function ([param], None, Pfunction_body exp_apply)) ~loc
end
| None ->
exp_apply in
(args, wrap)
(**
* Joins a 'body' and it's 'args' to form a Pexp_apply.
* Example:
* 'add' (body) and '[1, 2]' (args) become a Pexp_apply representing 'add(1, 2)'
*
* Note that `add(. 1, 2)(. 3, 4)` & `add(. 1, 2, . 3, 4)` both
* give `[[@uncurry] 1, 2, [@uncurry] 3, 4]]` as args.
* The dot is parsed as [@uncurry] to distinguish between specific
* uncurrying and [@bs]. They can appear in the same arg:
* `add(. [@bs] 1)` is a perfectly valid, the dot indicates uncurrying
* for the whole application of 'add' and [@bs] sits on the `1`.
* Due to the dot of uncurried application possibly appearing in any
* position of the args, we need to post-process the args and split
* all args in groups that are uncurried (or not).
* add(. 1, . 2) should be parsed as (add(. 1))(. 2)
* The args can be splitted here in [1] & [2], based on those groups
* we can recursively build the correct nested Pexp_apply here.
* -> Pexp_apply (Pexp_apply (add, 1), 2) (* simplified ast *)
*)
let mkexp_app_rev startp endp (body, args) =
let loc = mklocation startp endp in
if args = [] then {body with Ppxlib.pexp_loc = loc}
else
(*
* Post process the arguments and transform [@uncurry] into [@bs].
* Returns a tuple with a boolean (was it uncurried?) and
* the posible rewritten arg.
*)
let rec process_args acc es =
match es with
| (lbl, e)::es ->
let attrs = e.Ppxlib.pexp_attributes in
let hasUncurryAttr = ref false in
let newAttrs = List.filter ~f:(function
| { Ppxlib.attr_name = {txt = "uncurry"; _}; attr_payload = PStr []; _} ->
hasUncurryAttr := true;
false
| _ -> true) attrs
in
let uncurried = !hasUncurryAttr in
let newArg = (lbl, { e with pexp_attributes = newAttrs }) in
process_args ((uncurried, newArg)::acc) es
| [] -> acc
in
(*
* Groups all uncurried args falling under the same Pexp_apply
* Example:
* add(. 2, 3, . 4, 5) or add(. 2, 3)(. 4, 5) (equivalent)
* This results in two groups: (true, [2, 3]) & (true, [4, 5])
* Both groups have 'true' as their first tuple element, because
* they are uncurried.
* add(2, 3, . 4) results in the groups (false, [2, 3]) & (true, [4])
*)
let rec group grp acc = function
| (uncurried, arg)::xs ->
let (_u, grp) = grp in
if uncurried = true then begin
group (true, [arg]) ((_u, (List.rev grp))::acc) xs
end else begin
group (_u, (arg::grp)) acc xs
end
| [] ->
let (_u, grp) = grp in
List.rev ((_u, (List.rev grp))::acc)
in
(*
* Recursively transforms all groups into a (possibly uncurried)
* Pexp_apply
*
* Example:
* Given the groups (true, [2, 3]) & (true, [4, 5]) and body 'add',
* we get the two nested Pexp_apply associated with
* (add(. 2, 3))(. 4, 5)
*)
let rec make_appl body = function
| args::xs ->
let (uncurried, args) = args in
let expr = if args = [] then body
else
let (args, wrap) = process_underscore_application args in
let args_loc = match args, List.rev args with
| ((_, s)::_), ((_, e)::_) -> mklocation s.pexp_loc.loc_start e.pexp_loc.loc_end
| _ -> assert false in
let expr = mkexp ~loc:args_loc (Pexp_apply (body, args)) in
let expr = if uncurried then {expr with pexp_attributes = [uncurry_payload loc]} else expr in
wrap expr
in
make_appl expr xs
| [] -> {body with pexp_loc = loc}
in
let processed_args = process_args [] args in
let groups = group (false, []) [] processed_args in
make_appl body groups
let mkmod_app_unit ~loc (mexp: Ppxlib.module_expr) =
mkmod ~loc (Pmod_apply_unit mexp)
let mkmod_app (mexp: Ppxlib.module_expr) (marg: Ppxlib.module_expr) =
mkmod ~loc:(mklocation mexp.pmod_loc.loc_start marg.pmod_loc.loc_end)
(Pmod_apply (mexp, marg))
let bigarray_function ?(loc=dummy_loc()) str name =
ghloc ~loc (Ppxlib.Longident.Ldot(Ldot(Lident "Bigarray", str), name))
let bigarray_get ?(loc=dummy_loc()) arr arg =
let get = if !Clflags.unsafe then "unsafe_get" else "get" in
match arg with
[c1] ->
mkexp(Pexp_apply(mkexp ~ghost:true ~loc (Pexp_ident(bigarray_function ~loc "Array1" get)),
[Nolabel, arr; Nolabel, c1]))
| [c1;c2] ->
mkexp(Pexp_apply(mkexp ~ghost:true ~loc (Pexp_ident(bigarray_function ~loc "Array2" get)),
[Nolabel, arr; Nolabel, c1; Nolabel, c2]))
| [c1;c2;c3] ->
mkexp(Pexp_apply(mkexp ~ghost:true ~loc (Pexp_ident(bigarray_function ~loc "Array3" get)),
[Nolabel, arr; Nolabel, c1; Nolabel, c2; Nolabel, c3]))
| coords ->
mkexp(Pexp_apply(mkexp ~ghost:true ~loc (Pexp_ident(bigarray_function ~loc "Genarray" "get")),
[Nolabel, arr; Nolabel, mkexp ~ghost:true ~loc (Pexp_array coords)]))
let bigarray_set ?(loc=dummy_loc()) arr arg newval =
let set = if !Clflags.unsafe then "unsafe_set" else "set" in
match arg with
[c1] ->
mkexp(Pexp_apply(mkexp ~ghost:true ~loc (Pexp_ident(bigarray_function ~loc "Array1" set)),
[Nolabel, arr; Nolabel, c1; Nolabel, newval]))
| [c1;c2] ->
mkexp(Pexp_apply(mkexp ~ghost:true ~loc (Pexp_ident(bigarray_function ~loc "Array2" set)),
[Nolabel, arr; Nolabel, c1; Nolabel, c2; Nolabel, newval]))
| [c1;c2;c3] ->
mkexp(Pexp_apply(mkexp ~ghost:true ~loc (Pexp_ident(bigarray_function ~loc "Array3" set)),
[Nolabel, arr; Nolabel, c1; Nolabel, c2; Nolabel, c3; Nolabel, newval]))
| coords ->
mkexp(Pexp_apply(mkexp ~ghost:true ~loc (Pexp_ident(bigarray_function ~loc "Genarray" "set")),
[Nolabel, arr;
Nolabel, mkexp ~ghost:true ~loc (Pexp_array coords);
Nolabel, newval]))
let exp_of_label label =
mkexp ~loc:label.loc (Pexp_ident {label with txt=Lident(Ppxlib.Longident.last_exn label.txt)})
let pat_of_label label =
mkpat ~loc:label.loc (Ppat_var {label with txt=(Ppxlib.Longident.last_exn label.txt)})
let check_variable vl loc v =
if List.mem v ~set:vl then
raise_error (Variable_in_scope (loc,v)) loc
let varify_constructors var_names t =
let rec loop (t: Ppxlib.core_type) =
let desc =
match t.ptyp_desc with
| Ptyp_any -> Ppxlib.Ptyp_any
| Ptyp_var x ->
check_variable var_names t.ptyp_loc x;
Ptyp_var x
| Ptyp_arrow (label,core_type,core_type') ->
Ptyp_arrow(label, loop core_type, loop core_type')
| Ptyp_tuple lst -> Ptyp_tuple (List.map ~f:loop lst)
| Ptyp_constr( { txt = Lident s; _ }, []) when List.mem s ~set:var_names ->
Ptyp_var s
| Ptyp_constr(longident, lst) ->
Ptyp_constr(longident, List.map ~f:loop lst)
| Ptyp_object (lst, o) ->
Ptyp_object
(List.map
~f:(fun ({ Ppxlib.pof_desc; _ } as obj) ->
let pof_desc' = match pof_desc with
| Otag (s, t) -> Ppxlib.Otag (s, loop t)
| Oinherit t -> Oinherit (loop t)
in
{ obj with pof_desc = pof_desc' }) lst, o)
| Ptyp_class (longident, lst) ->
Ptyp_class (longident, List.map ~f:loop lst)
| Ptyp_alias(core_type, label) ->
check_variable var_names t.ptyp_loc label.txt;
Ptyp_alias(loop core_type, label)
| Ptyp_variant(row_field_list, flag, lbl_lst_option) ->
Ptyp_variant(List.map ~f:loop_row_field row_field_list,
flag, lbl_lst_option)
| Ptyp_poly(string_lst, core_type) ->
List.iter ~f:(fun x -> check_variable var_names t.ptyp_loc x.txt) string_lst;
Ptyp_poly(string_lst, loop core_type)
| Ptyp_package(longident,lst) ->
Ptyp_package(longident, List.map ~f:(fun (n,typ) -> (n,loop typ) ) lst)
| Ptyp_open (m, c) -> Ptyp_open (m, c)
| Ptyp_extension (s, arg) ->
Ptyp_extension (s, arg)
in
{t with ptyp_desc = desc}
and loop_row_field =
fun ({ prf_desc; _} as rf) ->
let prf_desc' = match prf_desc with
| Rtag(label, flag, lst) ->
Ppxlib.Rtag(label, flag, List.map ~f:loop lst)
| Rinherit t ->
Rinherit (loop t)
in
{ rf with prf_desc = prf_desc' }
in
loop t
let pexp_newtypes ?loc newtypes exp =
List.fold_right ~f:(fun newtype exp -> mkexp ?loc (Pexp_newtype (newtype, exp)))
newtypes ~init:exp
(**
I believe that wrap_type_annotation will automatically generate the type
arguments (type a) (type b) based on what was listed before the dot in a
polymorphic type annotation that uses locally abstract types.
*)
let wrap_type_annotation newtypes core_type body =
let exp = mkexp(Pexp_constraint(body,core_type)) in
let exp = pexp_newtypes newtypes exp in
let typ = mktyp ~ghost:true (Ptyp_poly(newtypes,varify_constructors (List.map ~f:(fun {txt; _} -> txt) newtypes) core_type)) in
(exp, typ)
let struct_item_extension (ext_attrs, ext_id) structure_items =
mkstr ~ghost:true (Pstr_extension ((ext_id, PStr structure_items), ext_attrs))
let wrap_str_ext ~loc body ext =
match ext with
| None -> body
| Some (ext_attrs, ext_id) ->
Ast_helper.Str.mk
~loc:(make_ghost_loc loc)
(Pstr_extension ((ext_id, PStr [body]), ext_attrs))
let wrap_sig_ext ~loc body ext =
match ext with
| None -> body
| Some (ext_attrs, ext_id) ->
Ppxlib.Psig_extension ((ext_id, PSig [mksig ~loc body]), ext_attrs)
let mk_quotedext ~loc (id, idloc, str, delim) =
let exp_id = mkloc id idloc in
let e =
let attrs =
[ { Ppxlib.attr_name = mkloc "reason.quoted_extension" loc
; attr_payload = PStr []
; attr_loc = Location.none
} ]
in
mkexp ~loc ~ghost:true ~attrs (Pexp_constant (Pconst_string (str, loc, delim)))
in
(exp_id, Ppxlib.PStr [mkstrexp e []])
let expression_extension ?loc (ext_attrs, ext_id) item_expr =
let loc = match loc with
| Some loc -> loc
| None -> make_ghost_loc (dummy_loc ())
in
let extension = (ext_id, Ppxlib.PStr [mkstrexp ~loc item_expr []]) in
Ast_helper.Exp.extension ~loc ~attrs:ext_attrs extension
(* There's no more need for these functions - this was for the following:
*
* fun % ext [@foo] arg => arg;
*
* Becoming
*
* [%ext (fun arg => arg) [@foo]]
*
* Which we no longer support.
*)
(* Applies the attributes to the body, then wraps entire thing in an extension
* expression, whose payload consists of a single structure item that is body
*)
(* let wrap_exp_attrs body (ext, attrs) = *)
(* (* todo: keep exact location for the entire attribute *) *)
(* let body = {body with pexp_attributes = attrs @ body.pexp_attributes} in *)
(* match ext with *)
(* | None -> body *)
(* | Some id -> mkexp ~ghost:true (Pexp_extension (id, PStr [mkstrexp body []])) *)
(* Why not just mkexp with the right attributes in the first place? *)
(* let mkexp_attrs d attrs = *)
(* wrap_exp_attrs (mkexp d) attrs *)
let mkcf_attrs ?(loc=dummy_loc()) d attrs =
Ast_helper.Cf.mk ~loc ~attrs d
let mkctf_attrs d attrs =
Ast_helper.Ctf.mk ~attrs d
let mklbs ext rf lb loc =
{ Reason_parser_def.lbs_bindings = [lb];
lbs_rec = rf;
lbs_extension = ext;
lbs_loc = loc; }
let addlbs (lbs: Reason_parser_def.let_bindings) lbs' =
{ lbs with Reason_parser_def.lbs_bindings = lbs.lbs_bindings @ lbs' }
let val_of_let_bindings (lbs: Reason_parser_def.let_bindings) =
let str = Ast_helper.Str.value lbs.lbs_rec lbs.lbs_bindings in
match lbs.lbs_extension with
| None -> str
| Some ext -> struct_item_extension ext [str]
let expr_of_let_bindings ~loc (lbs: Reason_parser_def.let_bindings) body =
let item_expr = Ast_helper.Exp.let_ ~loc lbs.lbs_rec lbs.lbs_bindings body in
match lbs.lbs_extension with
| None -> item_expr
| Some ext -> expression_extension ~loc:(make_ghost_loc loc) ext item_expr
let class_of_let_bindings (lbs: Reason_parser_def.let_bindings) body =
if lbs.lbs_extension <> None then
raise_error (Not_expecting (lbs.lbs_loc, "extension")) lbs.lbs_loc;
Ast_helper.Cl.let_ lbs.lbs_rec lbs.lbs_bindings body
(*
* arity_conflict_resolving_mapper is triggered when both "implicit_arity" "explicit_arity"
* are in the attribtues. In that case we have to remove "explicit_arity"
*
* However, if we simply remove explicit_arity, we would end up with a
* wrapping tuple which has only one component (inner tuple).
* This is against the invariance where tuples must have 2+ components.
* Therefore, in the case we have to remove explicit_arity, we also need to
* unwrap the tuple to expose the inner tuple directly.
*
*)
let reason_to_ml_swap_operator_mapper =
new Reason_syntax_util.reason_to_ml_swap_operator_mapper
let reason_mapper = object
inherit Ppxlib.Ast_traverse.map as super
method! expression expr =
match expr with
| {pexp_desc=Pexp_construct(lid, args);
pexp_loc;
pexp_attributes; _}
when Reason_syntax_util.attributes_conflicted "implicit_arity" "explicit_arity" pexp_attributes ->
let new_args =
match args with
| Some {pexp_desc = Pexp_tuple [sp]; _} -> Some sp
| _ -> args in
super#expression
{ pexp_desc=Pexp_construct(lid, new_args);
pexp_loc;
pexp_attributes = Reason_syntax_util.normalized_attributes "explicit_arity" pexp_attributes;
pexp_loc_stack = []
}
| x -> super#expression x
method! pattern pattern =
match pattern with
| {ppat_desc=Ppat_construct(lid, args);
ppat_loc;
ppat_attributes; _} when Reason_syntax_util.attributes_conflicted "implicit_arity" "explicit_arity" ppat_attributes ->
let new_args =
match args with
| Some (x, {ppat_desc = Ppat_tuple [sp]; _}) -> Some (x, sp)
| _ -> args
in
super#pattern
{ ppat_desc=Ppat_construct(lid, new_args);
ppat_loc;
ppat_attributes = Reason_syntax_util.normalized_attributes "explicit_arity" ppat_attributes;
ppat_loc_stack = [];
}
| x -> super#pattern x
end
let reason_mapper f a =
a |> f reason_to_ml_swap_operator_mapper |> f reason_mapper
let rewriteFunctorApp module_name elt loc =
let rec applies = function
| Ppxlib.Longident.Lident _ -> false
| Ldot (m, _) -> applies m
| Lapply (_, _) -> true in
let rec flattenModName = function
| Ppxlib.Longident.Lident id -> id
| Ldot (m, id) -> flattenModName m ^ "." ^ id
| Lapply (m1, m2) -> flattenModName m1 ^ "(" ^ flattenModName m2 ^ ")" in
let rec mkModExp = function
| Ppxlib.Longident.Lident id -> mkmod ~loc (Pmod_ident {txt=Lident id; loc})
| Ldot (m, id) -> mkmod ~loc (Pmod_ident {txt=Ldot (m, id); loc})
| Lapply (m1, m2) -> mkmod ~loc (Pmod_apply (mkModExp m1, mkModExp m2)) in
if applies module_name then
let flat = flattenModName module_name in
mkexp ~loc (Pexp_letmodule({txt=Some flat; loc},
mkModExp module_name,
mkexp(Pexp_ident {txt=Ldot (Lident flat, elt); loc})))
else
mkexp ~loc (Pexp_ident {txt=Ldot (module_name, elt); loc})
let jsx_component lid attrs children loc =
let is_module_name = function
| Ppxlib.Longident.Lident s
| Ldot (_, s) ->
(* s will be non-empty so the 0th access is fine. Modules can't start with underscore *)
String.get s 0 != '_' && s = String.capitalize_ascii s
| Lapply (_, _) -> true
in
let element_fn = if is_module_name lid.txt then
rewriteFunctorApp lid.txt "createElement" lid.loc
else
mkexp ~loc:lid.loc (Pexp_ident lid)
in
let body = mkexp(Pexp_apply(element_fn, attrs @ children)) ~loc in
let attribute = {
Ppxlib.attr_name = { Location.txt = "JSX"; loc };
attr_payload = PStr [];
attr_loc = loc;
}
in
{ body with pexp_attributes = attribute :: body.pexp_attributes }
let rec ignoreLapply = function
| Ppxlib.Longident.Lident id -> Ppxlib.Longident.Lident id
| Ldot (lid, id) -> Ldot (ignoreLapply lid, id)
| Lapply (m1, _) -> ignoreLapply m1
(* Like Ppxlib.Longident.flatten, but ignores `Lapply`s. Useful because 1) we don't want to require `Lapply` in
closing tags, and 2) Ppxlib.Longident.flatten doesn't support `Lapply`. *)
let rec flattenWithoutLapply = function
| Ppxlib.Longident.Lident id -> [id]
| Ldot (lid, id) -> flattenWithoutLapply lid @ [id]
| Lapply (m1, _) -> flattenWithoutLapply m1
let ensureTagsAreEqual startTag endTag loc =
if ignoreLapply startTag <> endTag then
let startTag = String.concat ~sep:"" (flattenWithoutLapply startTag) in
let endTag = String.concat ~sep:"" (flattenWithoutLapply endTag) in
if endTag <> "" then
Printf.ksprintf (syntax_error loc)
"Start tag <%s> does not match end tag </%s>" startTag endTag
(* `{. "foo": bar}` -> `Js.t {. foo: bar}` and {.. "foo": bar} -> `Js.t {.. foo: bar} *)
let mkBsObjTypeSugar ~loc ~closed rows =
let obj = mktyp ~loc (Ptyp_object (rows, closed)) in
let jsDotTCtor = { txt = Ppxlib.Longident.Ldot (Ppxlib.Longident.Lident "Js", "t"); loc } in
mktyp(Ptyp_constr(jsDotTCtor, [obj]))
let doc_loc loc = {txt = "ocaml.doc"; loc = loc}
let doc_attr text loc =
(* Here is where we will convert from markdown to odoc - transform the "text" *)
let exp =
{ Ppxlib.pexp_desc = Pexp_constant (Pconst_string(text, loc, None));
pexp_loc = loc;
pexp_attributes = [];
pexp_loc_stack = [];
}
in
let item =
{ Ppxlib.pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc }
in
{
Ppxlib.attr_name = doc_loc loc;
attr_payload = PStr [item];
attr_loc = loc
}
let prepend_attrs_to_labels attrs = function
| [] -> [] (* not possible for valid inputs *)
| (x: Ppxlib.label_declaration) :: xs ->
{ x with pld_attributes = attrs @ x.pld_attributes } :: xs
let raise_record_trailing_semi_error loc =
syntax_error_exp loc
"Record entries are separated by comma; \
we've found a semicolon instead."
let raise_record_trailing_semi_error' loc =
(Some (raise_record_trailing_semi_error loc), [])
let record_exp_spread_msg =
"Records can only have one `...` spread, at the beginning.
Explanation: since records have a known, fixed shape, a spread like `{a, ...b}` wouldn't make sense, as `b` would override every field of `a` anyway."
let record_pat_spread_msg =
"Record's `...` spread is not supported in pattern matches.
Explanation: you can't collect a subset of a record's field into its own record, since a record needs an explicit declaration and that subset wouldn't have one.
Solution: you need to pull out each field you want explicitly."
let lowercase_module_msg =
"Module names must start with an uppercase letter."
(* Handles "over"-parsing of spread syntax with `opt_spread`.
* The grammar allows a spread operator at every position, when
* generating the parsetree we raise a helpful error message. *)
let filter_raise_spread_syntax msg nodes =
List.map ~f:(fun (dotdotdot, node) ->
begin match dotdotdot with
| Some dotdotdotLoc -> syntax_error dotdotdotLoc msg
| None -> ()
end;
node
) nodes
(*
* See https://github.com/ocaml/ocaml/commit/e1e03820e5fea322aa3156721bc1cc0231668101
* Rely on the parsing rules for generic module types, and then
* extract a package type, enabling more explicit error messages
* *)
let package_type_of_module_type (pmty: Ppxlib.module_type) =
let map_cstr = function
| Ppxlib.Pwith_type (lid, ptyp) ->
let loc = ptyp.ptype_loc in
if ptyp.ptype_params <> [] then
syntax_error loc "parametrized types are not supported";
if ptyp.ptype_cstrs <> [] then
syntax_error loc "constrained types are not supported";
if ptyp.ptype_private <> Public then
syntax_error loc "private types are not supported";
(* restrictions below are checked by the 'with_constraint' rule *)
assert (ptyp.ptype_kind = Ptype_abstract);
assert (ptyp.ptype_attributes = []);
let ty =
match ptyp.ptype_manifest with
| Some ty -> ty
| None -> assert false
in
[lid, ty]
| _ ->
syntax_error pmty.pmty_loc "only 'with type t =' constraints are supported";
[]
in
match pmty with
| {pmty_desc = Pmty_ident lid; _} -> Some (lid, [])
| {pmty_desc = Pmty_with({pmty_desc = Pmty_ident lid; _}, cstrs); _} ->
Some (lid, List.flatten (List.map ~f:map_cstr cstrs))
| _ -> None
let add_brace_attr (expr: Ppxlib.expression) =
let attr = {
Ppxlib.attr_name = mknoloc "reason.preserve_braces";
attr_payload = PStr [];
attr_loc = Location.none
}
in
{ expr with pexp_attributes= attr :: expr.pexp_attributes }
%}
%[@recover.prelude
open Ppxlib
open Parsetree
open Ast_helper
let default_loc = ref Location.none
let default_expr () =
let id = Location.{txt = "merlin.hole"; loc = !default_loc} in
Exp.mk ~loc:!default_loc (Pexp_extension (id, PStr []))
let default_pattern () = Pat.any ~loc:!default_loc ()
let default_module_expr () = Mod.structure ~loc:!default_loc[]
let default_module_type () = Mty.signature ~loc:!default_loc[]
]
(* Tokens *)
%token AMPERAMPER
%token AMPERSAND
%token AND
%token AS
%token ASSERT
%token BACKQUOTE
%token BANG
%token BAR
%token BARBAR
%token BARRBRACKET
%token BEGIN
%token <char> CHAR
%token CLASS
%token COLON
%token COLONCOLON
%token COLONEQUAL
%token COLONGREATER
%token COMMA
%token CONSTRAINT
%token DO
%token DONE
%token DOT
%token DOTDOT
%token DOTDOTDOT
%token DOWNTO
%token ELSE
%token END
%token EOF
%token EQUAL
%token EXCEPTION
%token EXTERNAL
%token FALSE
%token <string * char option> FLOAT
[@recover.expr ("0.0", None)] [@recover.cost 2]
%token FOR
%token FUN ES6_FUN
%token FUNCTION
%token FUNCTOR
%token GREATER
%token GREATERRBRACE
%token GREATERDOTDOTDOT
%token IF
%token IN
%token INCLUDE
%token <string> INFIXOP0 [@recover.expr ""] [@recover.cost 2]
%token <string> INFIXOP1 [@recover.expr ""] [@recover.cost 2]
%token <string> INFIXOP2 [@recover.expr ""] [@recover.cost 2]
%token <string> INFIXOP3 [@recover.expr ""] [@recover.cost 2]
(* SLASHGREATER is an INFIXOP3 that is handled specially *)
%token SLASHGREATER
%token <string> INFIXOP4
%token <string> LETOP
%token <string> ANDOP
%token INHERIT
%token INITIALIZER
%token <string * char option> INT
[@recover.expr ("0", None)] [@recover.cost 2]
%token LAZY
%token LBRACE
%token LBRACELESS
%token LBRACKET
%token LBRACKETBAR
%token LBRACKETLESS
%token LBRACKETGREATER
%token LBRACKETPERCENT
%token LBRACKETPERCENTPERCENT
%token LESS
%token <string> LESSIDENT [@recover.expr ""] [@recover.cost 2]
%token <string> LESSUIDENT [@recover.expr ""] [@recover.cost 2]
%token LESSGREATER
%token LESSSLASHGREATER
%token LESSDOTDOTGREATER
%token EQUALGREATER
%token LET
%token <string> LIDENT [@recover.expr ""] [@recover.cost 2]
%token LPAREN
%token LBRACKETAT
%token OF
%token PRI
%token SWITCH
%token MINUS
%token MINUSDOT
%token MINUSGREATER
%token MODULE
%token MUTABLE
%token <nativeint> NATIVEINT [@recover.expr 0n] [@recover.cost 2]
%token NEW
%token NONREC
%token OBJECT
%token OPEN
%token OR
(* %token PARSER *)
%token PERCENT
%token PLUS
%token PLUSDOT
%token PLUSEQ
%token <string> PREFIXOP [@recover.expr ""] [@recover.cost 2]
%token <string> POSTFIXOP [@recover.expr ""] [@recover.cost 2]
%token PUB
%token QUESTION
%token QUOTE
%token RBRACE
%token RBRACKET
%token REC
%token RPAREN
%token <string> LESSSLASHIDENTGREATER [@recover.expr ""] [@recover.cost 2]
%token SEMI
%token SEMISEMI
%token SHARP
%token <string> SHARPOP
%token SHARPEQUAL
%token SIG
%token STAR
%token <string * string option * string option> STRING
[@recover.expr ("", None, None)] [@recover.cost 2]
%token
<string * Location.t * string * string option> QUOTED_STRING_EXPR
%token
<string * Location.t * string * string option> QUOTED_STRING_ITEM
%token STRUCT
%token THEN
%token TILDE
%token TO
%token TRUE
%token TRY
%token TYPE
%token <string> UIDENT [@recover.expr ""] [@recover.cost 2]
%token UNDERSCORE
%token VAL
%token VIRTUAL
%token WHEN
%token WHILE
%token WITH
%token <string * Location.t> COMMENT
%token <string> DOCSTRING
%token EOL
(* Precedences and associativities.
Tokens and rules have precedences and those precedences are used to
resolve what would otherwise be a conflict in the grammar.
Precedence and associativity/Resolving conflicts:
----------------------------
See [http://caml.inria.fr/pub/docs/manual-ocaml-4.00/manual026.html] section
about conflicts.
We will only use associativities with operators of the kind x * x -> x
for example, in the rules of the form expr: expr BINOP expr
in all other cases, we define two precedences if needed to resolve
conflicts.
*)
(* Question: Where is the SEMI explicit precedence? *)
%nonassoc below_SEMI
%right EQUALGREATER (* core_type2 (t => t => t) *)
%right COLON
%right EQUAL (* below COLONEQUAL (lbl = x := e) *)
%right COLONEQUAL (* expr (e := e := e) *)
%nonassoc QUESTION
%nonassoc WITH (* below BAR (match ... with ...) *)
%nonassoc AND (* above WITH (module rec A: SIG with ... and ...) *)
%nonassoc ELSE (* (if ... then ... else ...) *)
%nonassoc AS
%nonassoc below_BAR (* Allows "building up" of many bars *)
%left BAR (* pattern (p|p|p) *)
%right OR BARBAR (* expr (e || e || e) *)
%right AMPERSAND AMPERAMPER (* expr (e && e && e) *)
%left INFIXOP0 LESS GREATER GREATERDOTDOTDOT (* expr (e OP e OP e) *)
%left LESSDOTDOTGREATER (* expr (e OP e OP e) *)
%right INFIXOP1 (* expr (e OP e OP e) *)
%right COLONCOLON (* expr (e :: e :: e) *)
%left INFIXOP2 PLUS PLUSDOT MINUS MINUSDOT PLUSEQ (* expr (e OP e OP e) *)
%left PERCENT INFIXOP3 SLASHGREATER STAR (* expr (e OP e OP e) *)
%right INFIXOP4 (* expr (e OP e OP e) *)
(**
* With the way attributes are currently parsed, if we want consistent precedence for
*
* The OCaml parser parses the following attributes:
*
* let x = true && (false [@attrOnFalse])
* let x = true && false [@attrOnFalse]
* let x = 10 + 20 [@attrOn20]
* let x = (10 + 20) [@attrEntireAddition]
*
* As:
*
* let x = true && ((false)[@attrOnFalse ])
* let x = true && ((false)[@attrOnFalse ])
* let x = ((10 + 20)[@attrOn20 ])
* let x = ((10 + 20)[@attrEntireAddition ])
*
* That is because the precedence of tokens is configured as following, which
* only serves to treat certain infix operators as different than others with
* respect to attributes *only*.
*
* %right OR BARBAR
* %right AMPERSAND AMPERAMPER
* %nonassoc below_EQUAL
* %left INFIXOP0 EQUAL LESS GREATER
* %right INFIXOP1
* %nonassoc LBRACKETAT
* %right COLONCOLON
* %left INFIXOP2 PLUS PLUSDOT MINUS MINUSDOT PLUSEQ
* %left PERCENT INFIXOP3 SLASHGREATER STAR
* %right INFIXOP4
*
* So instead, with Reason, we treat all infix operators identically w.r.t.
* attributes. In expressions, they have the same precedence as function
* arguments, as if they are additional arguments to a function application.
*
* Note that unary subtractive/plus parses with lower precedence than function
* application (and attributes) This means that:
*
* let = - something blah blah [@attr];
*
* Will have the attribute applied to the entire content to the right of the
* unary minus, as if the attribute was merely another argument to the function
* application.
*
*
* To make the attribute apply to the unary -, wrap in parens.
*
* let = (- something blah blah) [@attr];
*
* Where arrows occur, it will (as always) obey the rules of function/type
* application.
*
* type x = int => int [@onlyAppliedToTheInt];
* type x = (int => int) [@appliedToTheArrow];
*
* However, unary subtractive/plus parses with *higher* precedence than infix
* application, so that
*
* 3 + - funcCall arg arg + 3;
*
* Is parsed as:
*
* 3 + (- (funcCall arg arg)) + 3;
*
* TODO:
*
* We would also like to bring this behavior to `!` as well, when ! becomes
* "not". This is so that you may do !someFunction(arg, arg) and have the
* entire function application negated. In fact, we may as well just have all
* of PREFIXOP have the unary precedence parsing behavior for consistency.
*)
%nonassoc attribute_precedence
%nonassoc prec_unary (* unary - *)
%nonassoc prec_constant_constructor (* cf. simple_expr (C versus C x) *)
(* Now that commas require wrapping parens (for tuples), prec_constr_appl no
* longer needs to be above COMMA, but it doesn't hurt *)
%nonassoc prec_constr_appl (* above AS BAR COLONCOLON COMMA *)
(* PREFIXOP and BANG precedence *)
%nonassoc below_DOT_AND_SHARP (* practically same as below_SHARP but we convey purpose *)
%nonassoc SHARP (* simple_expr/toplevel_directive *)
%nonassoc below_DOT
(* We need SHARPEQUAL to have lower precedence than `[` to make e.g.
this work: `foo #= bar[0]`. Otherwise it would turn into `(foo#=bar)[0]` *)
%left SHARPEQUAL
%nonassoc POSTFIXOP
(* LBRACKET and DOT are %nonassoc in OCaml, because the left and right sides
are never the same, therefore there doesn't need to be a precedence
disambiguation. This could also work in Reason, but by grouping the tokens
below into a single precedence rule it becomes clearer that they all have the
same precedence. *)
%left SHARPOP MINUSGREATER LBRACKET DOT
(* Finally, the first tokens of simple_expr are above everything else. *)
%nonassoc LBRACKETLESS LBRACELESS LBRACE LPAREN
(* Entry points *)
%start implementation (* for implementation files *)
%type <Ppxlib.structure> implementation
%start interface (* for interface files *)
%type <Ppxlib.signature> interface
%start toplevel_phrase (* for interactive use *)
%type <Ppxlib.toplevel_phrase> toplevel_phrase
%start use_file (* for the #use directive *)
%type <Ppxlib.toplevel_phrase list> use_file
%start parse_core_type
%type <Ppxlib.core_type> parse_core_type
%start parse_expression
%type <Ppxlib.expression> parse_expression
%start parse_pattern
%type <Ppxlib.pattern> parse_pattern
(* Instead of reporting an error directly, productions specified
* below will be reduced first and popped up in the stack to a higher
* level production.
*
* This is essential to error reporting as it is much friendier to provide
* a higher level error (e.g., "Expecting the parens to be closed" )
* as opposed to a low-level one (e.g., "Expecting to finish
* current type definition").
*
* See Menhir's manual for more details.
*)
%on_error_reduce structure_item
let_binding_body
letop_bindings
letop_binding_body
as_loc(attribute)+
type_longident
constr_longident
pattern
nonrec_flag
val_ident
SEMI?
fun_def(EQUAL,core_type)
fun_def(EQUALGREATER,non_arrowed_core_type)
expr_optional_constraint
%%
(* Entry points *)
implementation:
structure EOF
{ reason_mapper Reason_syntax_util.apply_mapper_to_structure $1 }
;
interface:
signature EOF
{ reason_mapper Reason_syntax_util.apply_mapper_to_signature $1 }
;
toplevel_phrase: embedded
( EOF { raise End_of_file }
| structure_item SEMI { Ppxlib.Ptop_def $1 }
| toplevel_directive SEMI {
let x: Ppxlib.toplevel_phrase = $1
in
x
}
) { reason_mapper Reason_syntax_util.apply_mapper_to_toplevel_phrase $1 }
;
use_file_no_mapper: embedded
( EOF { [] }
| structure_item SEMI use_file_no_mapper { Ppxlib.Ptop_def $1 :: $3 }
| toplevel_directive SEMI use_file_no_mapper { $1 :: $3 }
| structure_item EOF { [Ppxlib.Ptop_def $1 ] }
| toplevel_directive EOF { [$1] }
) {
let phrase: Ppxlib.toplevel_phrase list = $1 in
phrase
}
;
use_file:
use_file_no_mapper { reason_mapper Reason_syntax_util.apply_mapper_to_use_file $1 }
;
parse_core_type:
core_type EOF
{ reason_mapper Reason_syntax_util.apply_mapper_to_type $1 }
;
parse_expression:
expr EOF
{ reason_mapper Reason_syntax_util.apply_mapper_to_expr $1 }
;
parse_pattern:
pattern EOF
{ reason_mapper Reason_syntax_util.apply_mapper_to_pattern $1 }
;
(* Module expressions *)
module_parameter:
as_loc
( LPAREN RPAREN
{ Ppxlib.Unit }
| as_loc(mod_ident) COLON module_type
{ Ppxlib.Named ($1, $3) }
| as_loc(module_type)
{ Ppxlib.Named ({ txt = None; loc = $1.loc}, $1.txt) }
) {$1};
%inline two_or_more_module_parameters_comma_list:
lseparated_two_or_more(COMMA, module_parameter) COMMA? {$1}
;
functor_parameters:
| LPAREN RPAREN
{ let loc = mklocation $startpos $endpos in
[mkloc Ppxlib.Unit loc]
}
(* This single parameter case needs to be explicitly specified so that
* menhir can automatically remove the conflict between sigature:
*
* include (X)
* include (X, Y) => Z
*
* Even though the later is non-sensical (maybe it won't be one day?)
*)
| LPAREN module_parameter RPAREN {[$2]}
| LPAREN module_parameter COMMA RPAREN {[$2]}
| parenthesized(two_or_more_module_parameters_comma_list) { $1 }
;
module_complex_expr:
mark_position_mod
( module_expr
{ $1 }
| module_expr COLON module_type
{ mkmod(Pmod_constraint($1, $3)) }
| VAL expr
{ mkmod(Pmod_unpack $2) }
| VAL expr COLON MODULE? package_type
{ let loc = mklocation $symbolstartpos $endpos in
mkmod (Pmod_unpack(
mkexp ~ghost:true ~loc (Pexp_constraint($2, $5))))
}
| VAL expr COLON MODULE? package_type COLONGREATER MODULE? package_type
{ let loc = mklocation $symbolstartpos $endpos in
mkmod (Pmod_unpack(mkexp ~ghost:true ~loc (Pexp_coerce($2, Some $5, $8)))) }
| VAL expr COLONGREATER MODULE? package_type
{ let loc = mklocation $symbolstartpos $endpos in
mkmod (Pmod_unpack(mkexp ~ghost:true ~loc (Pexp_coerce($2, None, $5))))
}
) {$1};
module_arguments_comma_list:
lseparated_list(COMMA, module_complex_expr) COMMA? {$1}
;
module_arguments:
| module_expr_structure { [$1] }
| parenthesized(module_arguments_comma_list)
{ $1 }
;
module_expr_body: preceded(EQUAL,module_expr) | module_expr_structure { $1 };
module_expr_structure:
LBRACE structure RBRACE
{ mkmod ~loc:(mklocation $startpos $endpos) (Pmod_structure($2)) }
;
module_expr:
mark_position_mod
( as_loc(mod_longident)
{ mkmod(Pmod_ident $1) }
| module_expr_structure { $1 }
| LPAREN module_complex_expr RPAREN
{ $2 }
| LPAREN RPAREN
{ mkmod (Pmod_structure []) }
| extension
{ mkmod (Pmod_extension $1) }
(**
* Although it would be nice (and possible) to support annotated return value
* here, that wouldn't be consistent with what is possible for functions.
* Update: In upstream, it *is* possible to annotate return values for
* lambdas.
*)
| either(ES6_FUN,FUN) functor_parameters preceded(COLON,simple_module_type)? EQUALGREATER module_expr
{ let me = match $3 with
| None -> $5
| Some mt ->
let loc = mklocation $startpos($3) $endpos in
mkmod ~loc (Pmod_constraint($5, mt))
in
mk_functor_mod $2 me
}
| module_expr module_arguments
{ match $2 with
| [] -> mkmod_app_unit ~loc:(mklocation $symbolstartpos $endpos) $1
| xs -> List.fold_left ~f:mkmod_app ~init:$1 xs
}
| attribute module_expr %prec attribute_precedence
{ {$2 with pmod_attributes = $1 :: $2.pmod_attributes} }
) {$1};
(**
* Attributes/Extension points TODO:
* - Faux-ternary to support extension points (printing/parsing).
* - Audit to ensure every [item attributes] [item extensions] is supported.
* - wrap_exp_attrs / mkexp_attrs cleanup - no need for the confusing
* indirection.
* - Ensure proper parsing as ensured by commit:
* 4c48d802cb9e8110ab3b57ca0b6a02fdd5655283
* - Support the Item Extension + Item Attributes pattern/sugar/unification for
* all items in let sequences (let module etc / let open).
*)
(*
* In OCaml there are (confusingly) two ways to execute imperitive code at the
* top level:
*
* doStuff(); (* parsed as let _ = ... *)
* doMoreStuff(); (* parsed as let _ = ... *)
* ;; (* SEMISEMI *)
* let exportedThing = blah
*
* let _ = doStuff()
* let _ = doStuff()
* let exportedThing = blah (* SEMISEMI not needed if no leading seq_expr *)
*
*
* SEMISEMI (and a bunch of other inconsistencies/suprises) are the price you
* pay for not requiring a delimiter after each binding/imperitive action.
*
* let myFn () =
* let x = 0 in
* let y = 10 in
* x + y
*
* Also, in OCaml, there is a different syntax for let bindings in function
* bodies, where each let bindings group must end with IN.
*
* If we just *require* that every module export is terminated by a SEMI, and
* require that sequence expressions are grouped by some surrounding tokens {},
* then we can have a consistent, familiar way of executing imperitive code, or
* let bindings (without introducing SEMISEMI and without forcing you to write
* [let _ = imperitive()]).
*
* doStuff();
* doStuff();
* let exportedThing = blah; (* SEMISEMI not needed *)
*
* Also, we can then make function scoped let bindings have a consistent syntax
* with the top level module syntax.
*
* let myFn () => {
* let x = 0;
* let y = 10;
* x + y;
* };
}
*
* There are other practical reasons to require each structure item (or record
* item etc) to be terminated by a SEMI. It allows IDEs to correct indentation
* as you type. Otherwise (as in OCaml) your editor has to wait until you type
* `let` again to determine the indentation of the new line - for many editors,
* achieving that configuration is not easy.
*
* structure:
* seq_expr attribute* structure_tail { mkstrexp $1 $2 :: $3 }
* | structure_tail { $1 }
* ;
* structure_tail:
* { [] }
* | SEMISEMI structure { $2 }
* | structure_item SEMI structure_tail { $1 :: $3 }
*)
structure:
| (* Empty *) { [] }
| structure_item { $1 }
| structure_item SEMI structure { $1 @ $3 }
;
opt_LET_MODULE_ident:
| opt_LET_MODULE item_extension_sugar as_loc(mod_ident) { Some $2, $3 }
| opt_LET_MODULE as_loc(mod_ident) { None, $2 }
| opt_LET_MODULE item_extension_sugar? as_loc(LIDENT)
{ syntax_error $3.loc lowercase_module_msg; $2, { $3 with txt = Some $3.txt } }
;
opt_LET_MODULE_REC_ident:
| opt_LET_MODULE item_extension_sugar? REC as_loc(mod_ident) { $2, $4 }
| opt_LET_MODULE item_extension_sugar? REC as_loc(LIDENT)
{ syntax_error $4.loc lowercase_module_msg; $2, { $4 with txt = Some $4.txt } }
;
structure_item:
| mark_position_str
(* We consider a floating expression to be equivalent to a single let binding
to the "_" (any) pattern. *)
( item_attributes unattributed_expr
{ mkstrexp $2 $1 }
| item_attributes item_extension_sugar structure_item
{ let (ext_attrs, ext_id) = $2 in
struct_item_extension ($1@ext_attrs, ext_id) $3 }
| item_attributes
EXTERNAL item_extension_sugar? as_loc(val_ident) COLON core_type EQUAL primitive_declaration
{ let loc = mklocation $symbolstartpos $endpos in
wrap_str_ext
~loc
(mkstr (Pstr_primitive (Ast_helper.Val.mk $4 $6 ~prim:$8 ~attrs:$1 ~loc)))
$3
}
| item_attributes
EXTERNAL item_extension_sugar? as_loc(val_ident) COLON core_type SEMI
{ let loc = mklocation $symbolstartpos $endpos in
wrap_str_ext
~loc
(mkstr (Pstr_primitive (Ast_helper.Val.mk $4 $6 ~prim:[""] ~attrs:$1 ~loc)))
$3
}
| type_declarations
{
let (nonrec_flag, tyl, loc, extension) = $1 in
wrap_str_ext
~loc
(mkstr(Pstr_type (nonrec_flag, tyl)))
extension
}
| str_type_extension
{ let typext, loc, extension = $1 in
wrap_str_ext
~loc
(mkstr(Pstr_typext typext))
extension
}
| str_exception_declaration
{ mkstr(Pstr_exception (Ast_helper.Te.mk_exception ~loc:$1.pext_loc $1)) }
| item_attributes opt_LET_MODULE_ident module_binding_body
{ let loc = mklocation $symbolstartpos $endpos in
let ext, letmod = $2 in
wrap_str_ext
~loc
(mkstr(Pstr_module (Ast_helper.Mb.mk letmod $3 ~attrs:$1 ~loc)))
ext
}
| item_attributes opt_LET_MODULE_REC_ident module_binding_body
and_module_bindings*
{ let loc = mklocation $symbolstartpos $endpos($2) in
let ext, letmodule = $2 in
wrap_str_ext
~loc
(mkstr (Pstr_recmodule ((Ast_helper.Mb.mk letmodule $3 ~attrs:$1 ~loc) :: $4)))
ext
}
| item_attributes MODULE TYPE OF? as_loc(ident)
{ let loc = mklocation $symbolstartpos $endpos in
mkstr(Pstr_modtype (Ast_helper.Mtd.mk $5 ~attrs:$1 ~loc)) }
| item_attributes MODULE TYPE OF? as_loc(ident) module_type_body(EQUAL)
{ let loc = mklocation $symbolstartpos $endpos in
mkstr(Pstr_modtype (Ast_helper.Mtd.mk $5 ~typ:$6 ~attrs:$1 ~loc)) }
| open_declaration { $1 }
| item_attributes CLASS class_declaration_details and_class_declaration*
{ let (ident, binding, virt, params) = $3 in
let loc = mklocation $symbolstartpos $endpos($3) in
let first = Ast_helper.Ci.mk ident binding ~virt ~params ~attrs:$1 ~loc in
mkstr (Pstr_class (first :: $4))
}
| class_type_declarations
(* Each declaration has their own preceeding attribute* *)
{ mkstr(Pstr_class_type $1) }
| item_attributes INCLUDE module_expr
{ let loc = mklocation $symbolstartpos $endpos in
mkstr(Pstr_include (Ast_helper.Incl.mk $3 ~attrs:$1 ~loc))
}
| item_attributes item_extension
(* No sense in having item_extension_sugar for something that's already an
* item_extension *)
{ mkstr(Pstr_extension ($2, $1)) }
| let_bindings
{ val_of_let_bindings $1 }
) { [$1] }
| located_attributes
{
List.map
~f:(fun x -> mkstr ~loc:x.loc (Pstr_attribute (make_floating_doc x.txt)))
$1
}
;
module_binding_body:
| loption(functor_parameters) module_expr_body
{ mk_functor_mod $1 $2 }
| loption(functor_parameters) COLON module_type module_expr_body
{ let loc = mklocation $startpos($3) $endpos($4) in
mk_functor_mod $1 (mkmod ~loc (Pmod_constraint($4, $3))) }
;
and_module_bindings:
item_attributes AND as_loc(mod_ident) module_binding_body
{ Ast_helper.Mb.mk $3 $4 ~attrs:$1 ~loc:(mklocation $symbolstartpos $endpos) }
;
(* Module types *)
(*
(*
* For now, WITH constraints on module types shouldn't be considered
* "non-arrowed" because their WITH constraints themselves might contain arrows.
* We could ensure that you may only supply *non* arrowed types (or wrap arrowed
* types in parens) in thier WITH constraints, but that's just too difficult to
* think about so we will simply not consider WITH constrained module types as
* non-arrowed.
*
* Given this, we can probably take out the below_WITH precedence in the rules
* down below.
*)
*)
(* Allowed in curried let bidings *)
simple_module_type:
mark_position_mty
( parenthesized(module_parameter)
{ match $1.txt with
| Named ({ txt = None; _ }, x) -> x
| _ -> syntax_error_mty $1.loc "Expecting a simple module type"
}
| module_type_signature { $1 }
| as_loc(mty_longident)
{ mkmty (Pmty_ident $1) }
| extension
{ mkmty (Pmty_extension $1) }
| LPAREN MODULE TYPE OF module_expr RPAREN
{ mkmty (Pmty_typeof $5) }
) {$1};
module_type_signature:
LBRACE signature RBRACE
{ mkmty ~loc:(mklocation $startpos $endpos) (Pmty_signature $2) }
;
(*
(*
* For module types, we have:
*
* simple_module_type: (Non arrowed implied)
* non_arrowed_module_type
* module_type ::=
* module_type WITH ...
* non_arrowed_module_type
* (arg : module_type) => module_type
* module_type => module_type
*)
*)
%inline with_constraints:
WITH lseparated_nonempty_list(AND, with_constraint) { $2 }
module_type:
mark_position_mty
( module_type with_constraints
(* See note above about why WITH constraints aren't considered
* non-arrowed.
* We might just consider unifying the syntax for record extension with
* module extension/WITH constraints.
*
* mod MyModule = {
* ModuleToInclude...
* };
*
* let module CreateFactory
* (Spec: ContainerSpec)
* :{DescriptorFactoryIntf.S with
* type props = Spec.props and type dependencies = Spec.props} =>
*
*)
{ mkmty (Pmty_with($1, $2)) }
| simple_module_type
{$1}
| attribute module_type %prec attribute_precedence
{ {$2 with pmty_attributes = $1 :: $2.pmty_attributes} }
| functor_parameters EQUALGREATER module_type %prec below_SEMI
(**
* In OCaml, this is invalid:
* module MyFunctor: functor MT -> (sig end) = functor MT -> (struct end);;
*
* Not only must curried functor args have annotations, but functor
* annotations must include *names* for each argument in a functor type.
*
* module MyFunctor: functor (MT:MT) -> (sig end) = functor (MT:MT) -> (struct end)
*
* In Reason, we will parse the functor type:
*
* (AB:MT) -> ReturnSig
*
* as in:
* /----------------\
* module MyFunctor: (A:B) => ReturnSig = functor (C:D) => {}
*
* But only for the sake of compatibility with existing OCaml code (the
* ability to "view" OCaml code in Reason's syntax without loss of
* information.) Do not write identifiers in functor argument type
* positions - you wouldn't do it with functions, and they are
* meaningless in functors.
*
* But for sake of consistency (and for sake of a syntax that truly
* unifies functor syntax with function syntax, the following "sugars"
* will be parsed (and printed):
*
* A => B => C
*
* Is parsed into:
*
* functor (_:A) -> functor (_:B) -> C
*
* And a dummy "_" is inserted into the parse tree where no name has been
* provided.
*
* {SomeSig} => {} => {}
*
* Is parsed into:
*
* (_:SomeSig) => (_:{}) => {}
*
*
*)
{ mk_functor_mty $1 $3 }
) {$1};
signature:
| (* Empty *) { [] }
| signature_items { $1 }
| signature_items SEMI signature { $1 @ $3 }
;
signature_item:
| item_attributes
LET item_extension_sugar? as_loc(val_ident) COLON poly_type
{ let loc = mklocation $startpos($2) $endpos in
wrap_sig_ext
~loc
(Psig_value (Ast_helper.Val.mk $4 $6 ~attrs:$1 ~loc))
$3
}
| item_attributes
EXTERNAL item_extension_sugar? as_loc(val_ident) COLON core_type EQUAL primitive_declaration
{ let loc = mklocation $symbolstartpos $endpos in
wrap_sig_ext
~loc
(Psig_value (Ast_helper.Val.mk $4 $6 ~prim:$8 ~attrs:$1 ~loc))
$3
}
| item_attributes
EXTERNAL item_extension_sugar? as_loc(val_ident) COLON core_type SEMI
{ let loc = mklocation $symbolstartpos $endpos in
wrap_sig_ext
~loc
(Psig_value (Ast_helper.Val.mk $4 $6 ~prim:[""] ~attrs:$1 ~loc))
$3
}
| type_declarations
{ let (nonrec_flag, tyl, loc, extension) = $1 in
wrap_sig_ext
~loc
(Psig_type (nonrec_flag, tyl))
extension
}
| type_subst_declarations
{ Psig_typesubst $1 }
| sig_type_extension
{ let (typext, loc, extension) = $1 in
wrap_sig_ext
~loc
(Psig_typext typext)
extension
}
| sig_exception_declaration
{ Psig_exception $1 }
| item_attributes opt_LET_MODULE_ident module_declaration
{ let loc = mklocation $symbolstartpos $endpos in
let ext, letmod = $2 in
wrap_sig_ext
~loc
(Psig_module (Ast_helper.Md.mk letmod $3 ~attrs:$1 ~loc))
ext
}
| item_attributes opt_LET_MODULE_ident EQUAL as_loc(mod_longident)
{ let loc = mklocation $symbolstartpos $endpos in
let loc_mod = mklocation $startpos($4) $endpos($4) in
let ext, letmod = $2 in
wrap_sig_ext
~loc
(Psig_module
(Ast_helper.Md.mk
letmod
(Ast_helper.Mty.alias ~loc:loc_mod $4)
~attrs:$1
~loc))
ext
}
| item_attributes opt_LET_MODULE as_loc(UIDENT) COLONEQUAL as_loc(mod_ext_longident)
{ Psig_modsubst (Ast_helper.Ms.mk $3 $5 ~attrs:$1 ~loc:(mklocation $symbolstartpos $endpos))}
| item_attributes opt_LET_MODULE_REC_ident module_type_body(COLON)
and_module_rec_declaration*
{ let loc = mklocation $symbolstartpos $endpos($3) in
let ext, letmodule = $2 in
wrap_sig_ext
~loc
(Psig_recmodule (Ast_helper.Md.mk letmodule $3 ~attrs:$1 ~loc :: $4))
ext
}
| item_attributes MODULE TYPE as_loc(ident)
{ let loc = mklocation $symbolstartpos $endpos in
Psig_modtype (Ast_helper.Mtd.mk $4 ~attrs:$1 ~loc)
}
| item_attributes MODULE TYPE as_loc(ident) module_type_body(EQUAL)
{ let loc = mklocation $symbolstartpos $endpos in
Psig_modtype (Ast_helper.Mtd.mk $4 ~typ:$5 ~loc ~attrs:$1)
}
| item_attributes MODULE TYPE as_loc(ident) COLONEQUAL module_type
{ let loc = mklocation $symbolstartpos $endpos in
Psig_modtypesubst (Ast_helper.Mtd.mk $4 ~typ:$6 ~loc ~attrs:$1)
}
| open_description { $1 }
| item_attributes INCLUDE module_type
{ let loc = mklocation $symbolstartpos $endpos in
Ppxlib.Psig_include (Ast_helper.Incl.mk $3 ~attrs:$1 ~loc)
}
| class_descriptions
{ Psig_class $1 }
| class_type_declarations
{ Psig_class_type $1 }
| item_attributes item_extension
{ Ppxlib.Psig_extension ($2, $1) }
;
signature_items:
| as_loc(signature_item) { [mksig ~loc:$1.loc $1.txt] }
| located_attributes
{ List.map
~f:(fun x -> mksig ~loc:x.loc (Psig_attribute (make_floating_doc x.txt)))
$1 }
;
open_declaration:
item_attributes OPEN override_flag item_extension_sugar? module_expr
{
let loc = mklocation $symbolstartpos $endpos in
let opn =
Ppxlib.Pstr_open
(Ast_helper.Opn.mk $5 ~override:$3 ~attrs:$1 ~loc)
in
wrap_str_ext
~loc
(mkstr opn)
$4
}
;
open_description:
item_attributes OPEN override_flag item_extension_sugar? as_loc(mod_longident)
{ let loc = mklocation $symbolstartpos $endpos in
let opn =
Ppxlib.Psig_open (Ast_helper.Opn.mk $5 ~override:$3 ~attrs:$1 ~loc)
in
wrap_sig_ext ~loc opn $4
}
;
module_declaration:
loption(functor_parameters) module_type_body(COLON)
{ mk_functor_mty $1 $2 }
;
module_type_body(DELIM):
| DELIM module_type { $2 }
| module_type_signature { $1 }
;
and_module_rec_declaration:
item_attributes AND as_loc(mod_ident) module_type_body(COLON)
{ Ast_helper.Md.mk $3 $4 ~attrs:$1 ~loc:(mklocation $symbolstartpos $endpos) }
;
(* Class expressions *)
and_class_declaration:
item_attributes AND class_declaration_details
{ let (ident, binding, virt, params) = $3 in
let loc = mklocation $symbolstartpos $endpos in
Ast_helper.Ci.mk ident binding ~virt ~params ~attrs:$1 ~loc
}
;
class_declaration_details:
virtual_flag as_loc(LIDENT) ioption(class_type_parameters)
ioption(labeled_pattern_list) class_declaration_body
{
let tree = match $4 with
| None -> []
| Some (lpl, _uncurried) -> lpl
in
let body = List.fold_right ~f:mkclass_fun tree ~init:$5 in
let params = match $3 with None -> [] | Some x -> x in
($2, body, $1, params)
}
;
class_declaration_body:
preceded(COLON, class_constructor_type)?
either(preceded(EQUAL, class_expr), class_body_expr)
{ match $1 with
| None -> $2
| Some ct -> Ast_helper.Cl.constraint_ ~loc:(mklocation $symbolstartpos $endpos) $2 ct
}
;
class_expr_lets_and_rest:
mark_position_cl
( class_expr { $1 }
| let_bindings SEMI class_expr_lets_and_rest
{ class_of_let_bindings $1 $3 }
| object_body { mkclass (Pcl_structure $1) }
| LET? OPEN override_flag as_loc(mod_longident) SEMI class_expr_lets_and_rest
{ let loc = mklocation $startpos($2) $endpos($3) in
let od = Ast_helper.Opn.mk ~override:$3 ~loc $4 in
mkclass (Pcl_open (od, $6)) }
) {$1};
object_body_class_fields:
| lseparated_list(SEMI, class_field) SEMI? { List.concat $1 }
object_body:
| loption(located_attributes)
mark_position_pat(class_self_expr)
{ let attrs = List.map ~f:(fun x -> mkcf ~loc:x.loc (Pcf_attribute x.txt)) $1 in
Ast_helper.Cstr.mk $2 attrs }
| loption(located_attributes)
mark_position_pat(class_self_expr) SEMI
object_body_class_fields
{ let attrs = List.map ~f:(fun x -> mkcf ~loc:x.loc (Pcf_attribute x.txt)) $1 in
Ast_helper.Cstr.mk $2 (attrs @ $4) }
| object_body_class_fields
{ let loc = mklocation $symbolstartpos $symbolstartpos in
Ast_helper.Cstr.mk (mkpat ~loc (Ppat_var (mkloc "this" loc))) $1 }
;
class_self_expr:
| AS pattern { $2 }
class_expr:
mark_position_cl
( class_simple_expr
{ $1 }
| either(ES6_FUN,FUN) labeled_pattern_list EQUALGREATER class_expr
{ let (lp, _) = $2 in
List.fold_right ~f:mkclass_fun lp ~init:$4 }
| class_simple_expr labeled_arguments
(**
* This is an interesting way to "partially apply" class construction:
*
* let inst = new oldclass 20;
* class newclass = oldclass withInitArg;
* let inst = new newclass;
*)
{ mkclass(Pcl_apply($1, $2)) }
| attribute class_expr
{ {$2 with pcl_attributes = $1 :: $2.pcl_attributes} }
(*
When referring to class expressions (not regular types that happen to be
classes), you must refer to it as a class. This gives syntactic real estate
to place type parameters which are distinguished from constructor application
of arguments.
class myClass 'x = (class yourClass 'x int) y z;
inherit (class yourClass float int) initArg initArg;
...
let myVal: myClass int = new myClass 10;
*)
| CLASS as_loc(class_longident) loption(type_parameters)
{ mkclass(Pcl_constr($2, $3)) }
| extension
{ mkclass(Pcl_extension $1) }
) {$1};
class_simple_expr:
mark_position_cl
( as_loc(class_longident)
{ mkclass(Pcl_constr($1, [])) }
| class_body_expr
{ $1 }
| LPAREN class_expr COLON class_constructor_type RPAREN
{ mkclass(Pcl_constraint($2, $4)) }
| LPAREN class_expr RPAREN
{ $2 }
) {$1};
%inline class_body_expr: LBRACE class_expr_lets_and_rest RBRACE { $2 };
class_field:
| mark_position_cf
( item_attributes INHERIT override_flag class_expr as_loc(preceded(AS,LIDENT))?
{ mkcf_attrs (Pcf_inherit ($3, $4, $5)) $1 }
| item_attributes VAL value
{ mkcf_attrs (Pcf_val $3) $1 }
| item_attributes either(PUB {Public}, PRI {Private}) method_
{ let (a, b) = $3 in mkcf_attrs (Pcf_method (a, $2, b)) $1 }
| item_attributes CONSTRAINT constrain_field
{ mkcf_attrs (Pcf_constraint $3) $1 }
| item_attributes INITIALIZER mark_position_exp(simple_expr)
{ mkcf_attrs (Pcf_initializer $3) $1 }
| item_attributes item_extension
{ mkcf_attrs (Pcf_extension $2) $1 }
) { [$1] }
| located_attributes
{ List.map
~f:(fun x -> mkcf ~loc:x.loc (Pcf_attribute (make_floating_doc x.txt)))
$1 }
;
value:
(* TODO: factorize these rules (also with method): *)
| override_flag MUTABLE VIRTUAL as_loc(label) COLON core_type
{ if $1 = Override then
not_expecting $symbolstartpos $endpos
"members marked virtual may not also be marked overridden";
($4, Mutable, Cfk_virtual $6)
}
| override_flag MUTABLE VIRTUAL as_loc(label) type_constraint EQUAL expr
{ not_expecting $startpos($6) $endpos($6)
"not expecting equal - cannot specify value for virtual val";
let loc = mklocation $symbolstartpos $endpos in
let e = ghexp_constraint loc $7 $5 in
($4, Mutable, Cfk_concrete ($1, e)) }
| VIRTUAL mutable_flag as_loc(label) COLON core_type
{ ($3, $2, Cfk_virtual $5) }
| VIRTUAL mutable_flag as_loc(label) type_constraint EQUAL expr
{ not_expecting $startpos($5) $endpos($5)
"not expecting equal - cannot specify value for virtual val";
let loc = mklocation $symbolstartpos $endpos in
let e = ghexp_constraint loc $6 $4 in
($3, $2, Cfk_concrete (Fresh, e)) }
| override_flag mutable_flag as_loc(label) EQUAL expr
{ ($3, $2, Cfk_concrete ($1, $5)) }
| override_flag mutable_flag as_loc(label) type_constraint EQUAL expr
{ let loc = mklocation $symbolstartpos $endpos in
let e = ghexp_constraint loc $6 $4 in
($3, $2, Ppxlib.Cfk_concrete ($1, e)) }
;
method_:
(* TODO: factorize those rules... *)
| override_flag VIRTUAL as_loc(label) COLON poly_type
{ if $1 = Override then
syntax_error (mklocation $startpos $endpos)
"cannot override a virtual method";
($3, Cfk_virtual $5)
}
| override_flag as_loc(label) fun_def(EQUAL,core_type)
{ let loc = mklocation $symbolstartpos $endpos in
($2, Cfk_concrete ($1, mkexp ~ghost:true ~loc (Pexp_poly ($3, None))))
}
| override_flag as_loc(label) preceded(COLON,poly_type)?
either(preceded(EQUAL,expr), braced_expr)
(* Without locally abstract types, you'll see a Ptyp_poly in the Pexp_poly *)
{ let loc = mklocation $symbolstartpos $endpos in
($2, Cfk_concrete ($1, mkexp ~ghost:true ~loc (Pexp_poly($4, $3))))
}
| override_flag as_loc(label) COLON TYPE as_loc(LIDENT)+ DOT core_type
either(preceded(EQUAL,expr), braced_expr)
(* WITH locally abstract types, you'll see a Ptyp_poly in the Pexp_poly,
but the expression will be a Pexp_newtype and type vars will be
"varified". *)
{
(* For non, methods we'd create a pattern binding:
((Ppat_constraint(mkpatvar ..., Ptyp_poly (typeVars, poly_type_varified))),
exp_with_newtypes_constrained_by_non_varified)
For methods, we create:
Pexp_poly (Pexp_constraint (methodFunWithNewtypes, non_varified), Some (Ptyp_poly newTypes varified))
*)
let (exp_non_varified, poly_vars) = wrap_type_annotation $5 $7 $8 in
let exp = Ppxlib.Pexp_poly(exp_non_varified, Some poly_vars) in
let loc = mklocation $symbolstartpos $endpos in
($2, Ppxlib.Cfk_concrete ($1, mkexp ~ghost:true ~loc exp))
}
;
(* A parsing of class_constructor_type is the type of the class's constructor - and if the
constructor takes no arguments, then simply the class_instance_type of what is
returned.
The class_instance_type is type of the thing returned from a class constructor
which can either be:
- The identifier of another class.
- Type construction of a class type. [v1, v2] classIdentifier
- The type definition of the object returned (which is much like the type
of anonymous object but with different syntax, and ability to specify
inheritance):
- The class signature body may contain the type of methods (just like object types do)
- Inheritance of another class_instance_type.
- The instance variable "val"s.
- Constraints (same syntax that is used at class *definition* time)
When In Modules:
================
There are two primary language "class" constructs that are included in modules:
Class Definitions, and Class Type Definitions.
A Class Definition:
-------------------
Brings three things into the environment. For a class defined with name
[myClass], the environment would then contain the following:
1. A type called [myClass] which represents instances that have the same
structure as what is returned from the constructor - and do not have
any *more* members than what is returned from the constructor.
2. A type called [#myClass] which loosely speaking represents objects
that have the same structure as what is returned from the constructor,
but can also have *additional* fields as well. This ability to have
additional fields is accomplished via the same row-polymorphism of
objects without classes. Any reference to [#myClass] implicitly includes
a type variable, whose name we may not mention.
3. The class constructor for [myClass] - a function that "new" can be
invoked on. If the constructor is a function that takes arguments, then
the type of the constructor is the type of that function (including
the type of object returned). If it doesn't take arguments, then the
type of the constructor is the type of the object returned. You can
explicitly annotate/constrain the type of the constructor, and can
annotate them in module signatures as well.
The type constraint on a constructor has one syntactic nuance. The final
item separated by arrow must be prefixed with "new". This is merely to
resolve parsing conflicts. This can be fixed by making a parse rule for
types that parses *either* non-arowed class_instance_type or core_types,
but that means deferring the interpretation of patterns like "lowercase
identifier" and "type application", until it is known if that item was the
*final* arrow segment.
A Class Type Definition:
-----------------------
Brings two things into the environment. For a class type definition with
name [myClass], the environment would then contain the following:
1. A type called [myClass] which describes any object having *exactly*
the fields listed in the definition.
2. A type called [#myClass] which loosely speaking represents objects
that have the same structure as the definition, but can also have
*additional* fields as well.
When In Signatures:
================
A Class Definition (in signature becomes a class "description"):
-------------------
A Class Definition merely includes the type of that classes constructor.
[class myClass: args => new classType;] This merely admits that the module
includes a class whose constructor has that type.
A Class Type Definition is specified exactly as it is in a module (of
course, it may be abstract).
A Class Type Definition:
-----------------------
A Class Type Definition is specified exactly as it is in a module (of
course, it may be abstract).
Here are the parsing rules for everything discussed above:
Overview of Parsing Rules:
==========================
(Note: I have renamed class_type from the upstream compiler to
class_constructor_type and class_signature to class_instance_type for
clarity)
constructor_type:
| class_instance_type
| constructorFunction => typeWithArrows => class_instance_type
Modules
Class Definitions
class_declarations
| class LIDENT = class_expr
| class LIDENT = (class_expr : constructor_type)
"Pstr_class"
Class Type Definition
class_type_declarations
CLASS TYPE ident = class_instance_type
"Pstr_class_type"
Signatures
Class Descriptions (describes Class Definitions in Module)
class_descriptions
CLASS ident : constructor_type
"Psig_class"
Class Type Declarations (subset of Class Type Definitions in Module)
class_type_declarations
CLASS TYPE ident = class_instance_type
"Psig_class_type"
*)
class_constructor_type:
| class_instance_type { $1 }
| arrow_type_parameters EQUALGREATER class_constructor_type
{ List.fold_right ~f:mkcty_arrow $1 ~init:$3 }
;
class_type_arguments_comma_list:
| lseparated_nonempty_list(COMMA,core_type) COMMA? {$1}
;
class_instance_type:
mark_position_cty
( as_loc(clty_longident)
loption(parenthesized(class_type_arguments_comma_list))
{ mkcty (Pcty_constr ($1, $2)) }
| attribute class_instance_type
(* Note that this will compound attributes - so they will become
attached to whatever *)
{ {$2 with pcty_attributes = $1 :: $2.pcty_attributes} }
| class_type_body
{ $1 }
| extension
{ mkcty (Pcty_extension $1) }
) {$1};
class_type_body:
| LBRACE class_sig_body_cty RBRACE
{ mkcty ~loc:(mklocation $startpos $endpos) $2 }
| LBRACE DOT class_sig_body_cty RBRACE
{ let loc = mklocation $startpos $endpos in
let ct = mkcty ~loc $3 in
{ct with pcty_attributes = [uncurry_payload loc]}
}
;
class_sig_body_fields:
lseparated_list(SEMI, class_sig_field) SEMI? { List.concat $1 }
;
class_sig_body_cty:
| class_sig_body { Pcty_signature $1 }
| LET? OPEN override_flag as_loc(mod_longident) SEMI as_loc(class_sig_body_cty)
{ let {txt; loc} = $6 in
let od = Ast_helper.Opn.mk ~override:$3 ~loc:(mklocation $startpos($2) $endpos($3)) $4 in
Pcty_open (od, mkcty ~loc txt) }
;
class_sig_body:
| class_self_type
{ Ast_helper.Csig.mk $1 [] }
| class_self_type SEMI class_sig_body_fields
{ Ast_helper.Csig.mk $1 $3 }
| class_sig_body_fields
{ Ast_helper.Csig.mk (Ast_helper.Typ.mk ~loc:(mklocation $symbolstartpos $endpos) Ptyp_any) $1 }
;
class_self_type:
| AS core_type { $2 }
;
class_sig_field:
| mark_position_ctf
( item_attributes INHERIT class_instance_type
{ mkctf_attrs (Pctf_inherit $3) $1 }
| item_attributes VAL value_type
{ mkctf_attrs (Pctf_val $3) $1 }
| item_attributes PRI virtual_flag as_loc(label) COLON poly_type
{ mkctf_attrs (Pctf_method ($4, Private, $3, $6)) $1 }
| item_attributes PUB virtual_flag as_loc(label) COLON poly_type
{ mkctf_attrs (Pctf_method ($4, Public, $3, $6)) $1 }
| item_attributes CONSTRAINT constrain_field
{ mkctf_attrs (Pctf_constraint $3) $1 }
| item_attributes item_extension
{ mkctf_attrs (Pctf_extension $2) $1 }
) { [$1] }
| located_attributes
{ List.map
~f:(fun x -> mkctf ~loc:x.loc (Pctf_attribute (make_floating_doc x.txt)))
$1 }
;
value_type:
mutable_or_virtual_flags as_loc(label) COLON core_type
{ let (mut, virt) = $1 in ($2, mut, virt, $4) }
;
constrain:
core_type EQUAL core_type
{ ($1, $3, mklocation $symbolstartpos $endpos) }
;
constrain_field:
core_type EQUAL core_type
{ ($1, $3) }
;
class_descriptions:
item_attributes CLASS class_description_details and_class_description*
{ let (ident, binding, virt, params) = $3 in
let loc = mklocation $symbolstartpos $endpos in
(Ast_helper.Ci.mk ident binding ~virt ~params ~attrs:$1 ~loc :: $4)
}
;
and_class_description:
item_attributes AND class_description_details
{ let (ident, binding, virt, params) = $3 in
let loc = mklocation $symbolstartpos $endpos in
Ast_helper.Ci.mk ident binding ~virt ~params ~attrs:$1 ~loc
}
;
%inline class_type_parameter_comma_list:
| lseparated_nonempty_list(COMMA, type_parameter) COMMA? {$1}
%inline class_type_parameters:
parenthesized(class_type_parameter_comma_list)
{ $1 }
;
class_description_details:
virtual_flag as_loc(LIDENT) loption(class_type_parameters) COLON class_constructor_type
{ ($2, $5, $1, $3) }
;
class_type_declarations:
item_attributes CLASS TYPE class_type_declaration_details
and_class_type_declaration*
{ let (ident, instance_type, virt, params) = $4 in
let loc = mklocation $symbolstartpos $endpos in
(Ast_helper.Ci.mk ident instance_type ~virt ~params ~attrs:$1 ~loc :: $5)
}
;
and_class_type_declaration:
item_attributes AND class_type_declaration_details
{ let (ident, instance_type, virt, params) = $3 in
let loc = mklocation $symbolstartpos $endpos in
Ast_helper.Ci.mk ident instance_type ~virt ~params ~attrs:$1 ~loc
}
;
class_type_declaration_details:
virtual_flag as_loc(LIDENT) loption(class_type_parameters)
either(preceded(EQUAL,class_instance_type), class_type_body)
{ ($2, $4, $1, $3) }
;
%inline open_dot_declaration: as_loc(mod_longident)
{ let loc = mklocation $startpos($1) $endpos($1) in
let me = Ast_helper.Mod.ident ~loc $1 in
Ast_helper.Opn.mk ~loc me }
;
(* Core expressions *)
(* Note: If we will parse this as Pexp_apply, and it will
* not be printed with the braces, except in a couple of cases such as if/while
* loops.
*
* let add a b = {
* a + b;
* };
* TODO: Rename to [semi_delimited_block_sequence]
*
* Since seq_expr doesn't require a final SEMI, then without
* a final SEMI, a braced sequence with a single identifier is
* indistinguishable from a punned record.
*
* let myThing = {x};
*
* Is it {x:x} the record or x the identifier? We simply decided to break
* the tie and say that it should be parsed as a single identifier because
* single field records are incredibly rare. Apart from this one
* disadvantage, there's no disadvantage to not requiring the final brace.
*
* For each valid sequence item, we must list three forms:
*
* [item_extension_sugar] [nonempty_item_attributes] ITEM
* [nonempty_item_attributes] ITEM
* ITEM
*)
braced_expr:
mark_position_exp
( LBRACE seq_expr(SEMI?) RBRACE
{ add_brace_attr $2 }
| LBRACE DOTDOTDOT expr_optional_constraint COMMA? RBRACE
{ let loc = mklocation $symbolstartpos $endpos in
syntax_error_exp loc
"Record construction must have at least one field explicitly set" }
| LBRACE DOTDOTDOT expr_optional_constraint SEMI RBRACE
{ let loc = mklocation $startpos($4) $endpos($4) in
raise_record_trailing_semi_error loc }
| LBRACE record_expr RBRACE
{ mk_record_expr $2 }
| LBRACE record_expr_with_string_keys RBRACE
{ let loc = mklocation $symbolstartpos $endpos in
let (exten, fields) = $2 in
mkexp ~loc (Pexp_extension (mkloc ("mel.obj") loc,
PStr [mkstrexp (mkexp ~loc (Pexp_record(fields, exten))) []]))
}
(* Todo: Why is this not a simple_expr? *)
| LBRACE object_body RBRACE
{ mkexp (Pexp_object $2) }
) {$1};
seq_expr_no_seq [@recover.expr default_expr ()] (semi):
| expr semi { $1 }
| opt_LET_MODULE_ident module_binding_body SEMI seq_expr(SEMI?)
{ let loc = mklocation $symbolstartpos $endpos in
let ext, letmod = $1 in
let exp = mkexp (Pexp_letmodule(letmod, $2, $4)) in
match ext with
| None -> exp
| Some (ext_attrs, ext_id) ->
mkexp ~loc (Pexp_extension (ext_id, PStr [mkstrexp exp ext_attrs]))
}
| item_attributes LET? OPEN override_flag module_expr SEMI seq_expr(SEMI?)
{ let loc = (mklocation $startpos($1) $endpos($4)) in
let od = Ast_helper.Opn.mk ~override:$4 ~loc $5 in
let exp = mkexp (Pexp_open(od, $7)) in
{ exp with pexp_attributes = $1 }
}
| item_attributes LET? OPEN item_extension_sugar module_expr SEMI seq_expr(SEMI?)
{ let loc = (mklocation $startpos($1) $endpos($4)) in
let od = Ast_helper.Opn.mk ~override:Fresh ~loc $5 in
let exp =
let exp = mkexp (Pexp_open(od, $7)) in
{ exp with pexp_attributes = $1 }
in
let (ext_attrs, ext_id) = $4 in
mkexp ~loc (Pexp_extension (ext_id, PStr [mkstrexp exp ext_attrs]))
}
| str_exception_declaration SEMI seq_expr(SEMI?) {
mkexp (Pexp_letexception ($1, $3)) }
| let_bindings SEMI seq_expr(SEMI?)
{ let loc = mklocation $startpos($1) $endpos($3) in
expr_of_let_bindings ~loc $1 $3
}
| let_bindings semi
{ let loc = mklocation $symbolstartpos $endpos in
expr_of_let_bindings ~loc $1 (ghunit ~loc ())
}
| item_attributes as_loc(LETOP) letop_bindings SEMI seq_expr(SEMI?)
{ let (pbop_pat, pbop_exp, rev_ands) = $3 in
let ands = List.rev rev_ands in
let pbop_loc = mklocation $startpos($2) $endpos($3) in
let let_ = {Ppxlib.pbop_op = $2; pbop_pat; pbop_exp; pbop_loc} in
mkexp ~attrs:$1 ~loc:pbop_loc (Pexp_letop { let_; ands; body = $5}) }
;
seq_expr(semi):
mark_position_exp
( seq_expr_no_seq(semi)
{ $1 }
| item_extension_sugar mark_position_exp(seq_expr_no_seq(SEMI?))
{ expression_extension $1 $2 }
| expr SEMI seq_expr(SEMI?)
{ mkexp (Pexp_sequence($1, $3)) }
| item_extension_sugar expr SEMI seq_expr(SEMI?)
{ let loc = mklocation $startpos($1) $endpos($2) in
mkexp (Pexp_sequence(expression_extension ~loc $1 $2, $4)) }
) { $1 }
;
(*
A:
let named a::a b::b => a + b;
type named = a::int => b::int => int;
B:
let namedAlias a::aa b::bb => aa + bb;
let namedAlias a::aa b::bb => aa + bb;
type namedAlias = a::int => b::int => int;
C:
let namedAnnot a::(a:int) b::(b:int) => 20;
D:
let namedAliasAnnot a::(aa:int) b::(bb:int) => 20;
E:
let myOptional a::a=? b::b=? () => 10;
type named = a::int? => b::int? => unit => int;
F:
let optionalAlias a::aa=? b::bb=? () => 10;
G:
let optionalAnnot a::(a:int)=? b::(b:int)=? () => 10;
H:
let optionalAliasAnnot a::(aa:int)=? b::(bb:int)=? () => 10;
I: :
let defOptional a::a=10 b::b=10 () => 10;
type named = a::int? => b::int? => unit => int;
J:
let defOptionalAlias a::aa=10 b::bb=10 () => 10;
K:
let defOptionalAnnot a::(a:int)=10 b::(b:int)=10 () => 10;
L:
let defOptionalAliasAnnot a::(aa:int)=10 b::(bb:int)=10 () => 10;
M: Invoking them - Punned :
let resNotAnnotated = named a::a b::b;
N::
let resAnnotated = (named a::a b::b :int);
O: Invoking them :
let resNotAnnotated = named a::a b::b;
P: Invoking them :
let resAnnotated = (named a::a b::b :int);
Q: Here's why "punning" doesn't work! :
Is b:: punned with a final non-named arg, or is b:: supplied b as one named arg? :
let b = 20;
let resAnnotated = (named a::a b:: b);
R: Proof that there are no ambiguities with return values being annotated :
let resAnnotated = (named a::a b :ty);
S: Explicitly passed optionals are a nice way to say "use the default value":
let explicitlyPassed = myOptional a::?None b::?None;
T: Annotating the return value of the entire function call :
let explicitlyPassedAnnotated = (myOptional a::?None b::?None :int);
U: Explicitly passing optional with identifier expression :
let a = None;
let explicitlyPassed = myOptional a::?a b::?None;
let explicitlyPassedAnnotated = (myOptional a::?a b::?None :int);
*)
labeled_pattern_constraint:
| AS pattern_optional_constraint { fun _punned -> $2 }
| preceded(COLON, core_type)?
{ fun punned ->
let pat = mkpat (Ppat_var punned) ~loc:punned.loc in
match $1 with
| None -> pat
| Some typ ->
let loc = mklocation punned.loc.loc_start $endpos in
mkpat ~loc (Ppat_constraint(pat, typ))
}
;
labeled_pattern:
as_loc
( TILDE as_loc(LIDENT) labeled_pattern_constraint
{ Reason_parser_def.Term (Labelled $2.txt, None, $3 $2) }
| TILDE as_loc(LIDENT) labeled_pattern_constraint EQUAL expr
{ Reason_parser_def.Term (Optional $2.txt, Some $5, $3 $2) }
| TILDE as_loc(LIDENT) labeled_pattern_constraint EQUAL QUESTION
{ Reason_parser_def.Term (Optional $2.txt, None, $3 $2) }
| pattern_optional_constraint
{ Reason_parser_def.Term (Nolabel, None, $1) }
| TYPE LIDENT
{ Reason_parser_def.Type $2 }
) { $1 }
;
%inline labelled_pattern_comma_list:
lseparated_nonempty_list(COMMA, labeled_pattern) COMMA? { $1 };
%inline labeled_pattern_list:
| LPAREN RPAREN {
let loc = mklocation $startpos $endpos in
([mkloc (Reason_parser_def.Term (Nolabel, None, mkpat_constructor_unit loc loc)) loc], false)
}
| parenthesized(labelled_pattern_comma_list) {
($1, false)
}
| LPAREN DOT RPAREN {
let loc = mklocation $startpos $endpos in
([mkloc (Reason_parser_def.Term (Nolabel, None, mkpat_constructor_unit loc loc)) loc], true)
}
| LPAREN DOT labelled_pattern_comma_list RPAREN {
($3, true)
}
;
es6_parameters:
| labeled_pattern_list { $1 }
| as_loc(UNDERSCORE)
{ ([{$1 with txt = Term (Nolabel, None, mkpat ~loc:$1.loc Ppat_any)}], false) }
| simple_pattern_ident
{ ([mkloc (Reason_parser_def.Term (Nolabel, None, $1)) $1.ppat_loc], false) }
;
(* TODO: properly fix JSX labelled/optional stuff *)
jsx_arguments:
(* empty *) { [] }
| LIDENT EQUAL QUESTION simple_expr jsx_arguments
{ (* a=?b *)
[(Optional $1, $4)] @ $5
}
| QUESTION LIDENT jsx_arguments
{ (* <Foo ?bar /> punning with explicitly passed optional *)
let loc_lident = mklocation $startpos($2) $endpos($2) in
[(Optional $2, mkexp (Pexp_ident {txt = Lident $2; loc = loc_lident}) ~loc:loc_lident)] @ $3
}
| LIDENT EQUAL simple_expr jsx_arguments
{ (* a=b *)
[(Labelled $1, $3)] @ $4
}
| LIDENT jsx_arguments
{ (* a (punning) *)
let loc_lident = mklocation $startpos($1) $endpos($1) in
[(Labelled $1, mkexp (Pexp_ident {txt = Lident $1; loc = loc_lident}) ~loc:loc_lident)] @ $2
}
| as_loc(INFIXOP3)
(* extra rule to provide nice error messages in the case someone
* wrote: <Description term=<Text text="Age" />> child </Description>
* or <Foo bar=<Baz />/>
* />> & />/> are lexed as infix tokens *)
{
begin match $1.txt with
| "/>>" ->
syntax_error $1.loc
{|JSX in a JSX-argument needs to be wrapped in braces.
If you wrote:
<Description term=<Text text="Age" />> child </Description>
Try wrapping <Text /> in braces.
<Description term={<Text text="Age" />}> child </Description>|}
| "/>/>" ->
syntax_error $1.loc
{|JSX in a JSX-argument needs to be wrapped in braces.
If you wrote:
<Description term=<Text text="Age" />/>
Try wrapping <Text /> in braces.
<Description term={<Text text="Age" />} />|}
| _ -> syntax_error $1.loc "Syntax error"
end;
[]
}
;
jsx_start_tag_and_args:
as_loc(LESSIDENT) jsx_arguments
{ let name = Reason_syntax_util.parse_lid $1.txt in
(jsx_component {$1 with txt = name} $2, name)
}
| LESS as_loc(LIDENT) jsx_arguments
{ let name = Reason_syntax_util.parse_lid $2.txt in
(jsx_component {$2 with txt = name} $3, name)
}
| LESS as_loc(mod_ext_longident) jsx_arguments
{ jsx_component $2 $3, $2.txt }
| as_loc(mod_ext_lesslongident) jsx_arguments
{ jsx_component $1 $2, $1.txt }
;
jsx_start_tag_and_args_without_leading_less:
as_loc(mod_ext_longident) jsx_arguments
{ (jsx_component $1 $2, $1.txt) }
| as_loc(LIDENT) jsx_arguments
{ let lident = Ppxlib.Longident.Lident $1.txt in
(jsx_component {$1 with txt = lident } $2, lident)
}
;
greater_spread:
| GREATERDOTDOTDOT
| GREATER DOTDOTDOT { ">..." }
jsx:
| LESSGREATER simple_expr_no_call* LESSSLASHGREATER
{ let loc = mklocation $symbolstartpos $endpos in
let body = mktailexp_extension loc $2 None in
makeFrag loc body
}
(* There is not need yet for <> ...expr </> because it would currently
* parse as expr.
| LESSGREATER DOTDOTDOT simple_expr_no_call LESSSLASHGREATER
{ let loc = mklocation $symbolstartpos $endpos in
makeFrag loc $3
}
*)
| jsx_start_tag_and_args SLASHGREATER
{ let (component, _) = $1 in
let loc = mklocation $symbolstartpos $endpos in
component [
(Labelled "children", mktailexp_extension loc [] None);
(Nolabel, mkexp_constructor_unit loc loc)
] loc
}
| jsx_start_tag_and_args GREATER simple_expr_no_call* LESSSLASHIDENTGREATER
{ let (component, start) = $1 in
let loc = mklocation $startpos($4) $endpos in
(* TODO: Make this tag check simply a warning *)
let endName = Reason_syntax_util.parse_lid $4 in
let _ = ensureTagsAreEqual start endName loc in
let siblings = $3 in
component [
(Labelled "children", mktailexp_extension loc siblings None);
(Nolabel, mkexp_constructor_unit loc loc)
] loc
}
| jsx_start_tag_and_args greater_spread simple_expr_no_call LESSSLASHIDENTGREATER
(* <Foo> ...bar </Foo> or <Foo> ...((a) => 1) </Foo> *)
{ let (component, start) = $1 in
let loc = mklocation $symbolstartpos $endpos in
(* TODO: Make this tag check simply a warning *)
let endName = Reason_syntax_util.parse_lid $4 in
let _ = ensureTagsAreEqual start endName loc in
let child = $3 in
component [
(Labelled "children", child);
(Nolabel, mkexp_constructor_unit loc loc)
] loc
}
;
jsx_without_leading_less:
| GREATER simple_expr_no_call* LESSSLASHGREATER {
let loc = mklocation $symbolstartpos $endpos in
let body = mktailexp_extension loc $2 None in
makeFrag loc body
}
| jsx_start_tag_and_args_without_leading_less SLASHGREATER {
let (component, _) = $1 in
let loc = mklocation $symbolstartpos $endpos in
component [
(Labelled "children", mktailexp_extension loc [] None);
(Nolabel, mkexp_constructor_unit loc loc)
] loc
}
| jsx_start_tag_and_args_without_leading_less GREATER simple_expr_no_call* LESSSLASHIDENTGREATER {
let (component, start) = $1 in
let loc = mklocation $symbolstartpos $endpos in
(* TODO: Make this tag check simply a warning *)
let endName = Reason_syntax_util.parse_lid $4 in
let _ = ensureTagsAreEqual start endName loc in
let siblings = $3 in
component [
(Labelled "children", mktailexp_extension loc siblings None);
(Nolabel, mkexp_constructor_unit loc loc)
] loc
}
| jsx_start_tag_and_args_without_leading_less greater_spread simple_expr_no_call LESSSLASHIDENTGREATER {
let (component, start) = $1 in
let loc = mklocation $symbolstartpos $endpos in
(* TODO: Make this tag check simply a warning *)
let endName = Reason_syntax_util.parse_lid $4 in
let _ = ensureTagsAreEqual start endName loc in
let child = $3 in
component [
(Labelled "children", child);
(Nolabel, mkexp_constructor_unit loc loc)
] loc
}
;
optional_expr_extension:
| (* empty *) { fun ~loc:_ exp -> exp }
| item_extension_sugar { fun ~loc exp -> expression_extension ~loc $1 exp }
;
(*
* Parsing of expressions is quite involved as it depends on context.
* At the top-level of a structure, expressions can't have attributes
* (those are attached to the structure).
* In other places, attributes are allowed.
*
* The generic parts are represented by unattributed_expr_template(_).
* Then unattributed_expr represents the concrete unattributed expr
* while expr adds an attribute rule to unattributed_expr_template.
*)
%inline unattributed_expr_template(E):
mark_position_exp
( simple_expr
{ $1 }
| FUN optional_expr_extension fun_def(EQUALGREATER,non_arrowed_core_type)
{ let loc = mklocation $startpos $endpos in
$2 ~loc $3 }
| ES6_FUN es6_parameters EQUALGREATER expr
{ let (ps, uncurried) = $2 in
let exp = List.fold_right ~f:mkexp_fun ps ~init:$4 in
if uncurried then
let loc = mklocation $startpos $endpos in
{exp with pexp_attributes = (uncurry_payload loc)::exp.pexp_attributes}
else exp
}
| ES6_FUN es6_parameters COLON non_arrowed_core_type EQUALGREATER expr
{ let (ps, uncurried) = $2 in
let exp = List.fold_right ~f:mkexp_fun ps
~init:(ghexp_constraint (mklocation $startpos($4) $endpos) $6 (Some $4, None)) in
if uncurried then
let loc = mklocation $startpos $endpos in
{exp with pexp_attributes = (uncurry_payload loc)::exp.pexp_attributes}
else exp
}
(* List style rules like this often need a special precendence
such as below_BAR in order to let the entire list "build up"
*)
| FUN optional_expr_extension match_cases(expr) %prec below_BAR
{ let loc = mklocation $startpos $endpos in
$2 ~loc (mkexp (Pexp_function ([], None, (Pfunction_cases ($3, loc, []))))) }
| SWITCH optional_expr_extension simple_expr_no_constructor
LBRACE match_cases(seq_expr(SEMI?)) RBRACE
{ let loc = mklocation $startpos $endpos in
$2 ~loc (mkexp (Pexp_match ($3, $5))) }
| TRY optional_expr_extension simple_expr_no_constructor
LBRACE match_cases(seq_expr(SEMI?)) RBRACE
{ let loc = mklocation $startpos $endpos in
$2 ~loc (mkexp (Pexp_try ($3, $5))) }
| IF optional_expr_extension parenthesized_expr
simple_expr ioption(preceded(ELSE,expr))
{ let loc = mklocation $startpos $endpos in
$2 ~loc (mkexp (Pexp_ifthenelse($3, $4, $5))) }
| WHILE optional_expr_extension parenthesized_expr simple_expr
{ let loc = mklocation $startpos $endpos in
$2 ~loc (mkexp (Pexp_while($3, $4))) }
| FOR optional_expr_extension LPAREN pattern IN expr direction_flag expr RPAREN
simple_expr
{ let loc = mklocation $startpos $endpos in
$2 ~loc (mkexp (Pexp_for($4, $6, $8, $7, $10))) }
| LPAREN COLONCOLON RPAREN LPAREN expr COMMA expr RPAREN
{ let loc_colon = mklocation $startpos($2) $endpos($2) in
let loc = mklocation $symbolstartpos $endpos in
mkexp_cons loc_colon (mkexp ~ghost:true ~loc (Pexp_tuple[$5;$7])) loc
}
| E as_loc(infix_operator) expr
{ let op = match $2.txt with
| "->" -> {$2 with txt = "|."}
| _ -> $2
in mkinfix $1 op $3
}
| as_loc(subtractive) expr %prec prec_unary
{ mkuminus $1 $2 }
| as_loc(additive) expr %prec prec_unary
{ mkuplus $1 $2 }
| as_loc(BANG {"!"}) expr %prec prec_unary
{ mkexp(Pexp_apply(mkoperator $1, [Nolabel,$2])) }
| simple_expr DOT as_loc(label_longident) EQUAL expr
{ mkexp(Pexp_setfield($1, $3, $5)) }
| simple_expr LBRACKET expr RBRACKET EQUAL expr
{ let loc = mklocation $symbolstartpos $endpos in
let exp = Ppxlib.Pexp_ident(array_function ~loc "Array" "set") in
mkexp(Pexp_apply(mkexp ~ghost:true ~loc exp,
[Nolabel,$1; Nolabel,$3; Nolabel,$6]))
}
| simple_expr DOT LBRACKET expr RBRACKET EQUAL expr
{ let loc = mklocation $symbolstartpos $endpos in
let exp = Ppxlib.Pexp_ident(array_function ~loc "String" "set") in
mkexp(Pexp_apply(mkexp ~ghost:true ~loc exp,
[Nolabel,$1; Nolabel,$4; Nolabel,$7]))
}
| simple_expr bigarray_access EQUAL expr
{ let loc = mklocation $symbolstartpos $endpos in
bigarray_set ~loc $1 $2 $4
}
| as_loc(label) EQUAL expr
{ mkexp(Pexp_setinstvar($1, $3)) }
| ASSERT simple_expr
{ mkexp (Pexp_assert $2) }
| LAZY simple_expr
{ mkexp (Pexp_lazy $2) }
(*
* Ternary is just a shortcut for:
*
* switch expression { | true => expr1 | false => expr2 }
*
* The COLON token priority is below QUESTION so that the following parses:
*
* x ? y :
* z ? q : r
*
* As
*
* x ? y :
* (z ? q : r)
*
* Instead of:
*
* (x ? y :
* z) ? q : r
*
* When a question mark is seen, *this* parsing rule has lower priority so
* that we, instead, shift the qusetion mark so that the *latter* ternary is
* recognized first on the top of the stack. (z ? q : r).
*)
| E QUESTION expr COLON expr
{ (* Should use ghost expressions, but not sure how that would work with source maps *)
(* So ? will become true and : becomes false for now*)
let loc_question = mklocation $startpos($2) $endpos($2) in
let loc_colon = mklocation $startpos($4) $endpos($4) in
let fauxTruePat =
Ast_helper.Pat.mk ~loc:loc_question (Ppat_construct({txt = Lident "true"; loc = loc_question}, None)) in
let fauxFalsePat =
Ast_helper.Pat.mk ~loc:loc_colon (Ppat_construct({txt = Lident "false"; loc = loc_colon}, None)) in
let fauxMatchCaseTrue = Ast_helper.Exp.case fauxTruePat $3 in
let fauxMatchCaseFalse = Ast_helper.Exp.case fauxFalsePat $5 in
mkexp (Pexp_match ($1, [fauxMatchCaseTrue; fauxMatchCaseFalse]))
}
) {$1};
(*
* Much like how patterns are partitioned into pattern/simple_pattern,
* expressions are divided into expr/simple_expr.
* expr: contains function application, but simple_expr doesn't (unless it's
* wrapped in parens).
*)
expr [@recover.expr default_expr ()]:
| unattributed_expr_template(expr) { $1 }
| mark_position_exp(
attribute expr { {$2 with pexp_attributes = $1 :: $2.pexp_attributes} }
%prec attribute_precedence
)
{ $1 }
;
unattributed_expr:
unattributed_expr_template(unattributed_expr) { $1 };
parenthesized_expr:
| braced_expr
{ $1 }
| LPAREN DOT RPAREN
{ let loc = mklocation $startpos $endpos in
mkexp_constructor_unit ~uncurried:true loc loc }
| LPAREN expr_list RPAREN
{ may_tuple $startpos $endpos $2 }
;
%inline array_expr_list:
LBRACKETBAR
lseparated_list(COMMA, opt_spread(expr_optional_constraint))
COMMA?
BARRBRACKET
{ let msg = "Arrays can't use the `...` spread currently. Please use `concat` or other Array helpers." in
filter_raise_spread_syntax msg $2
};
%inline bigarray_access:
DOT LBRACE lseparated_nonempty_list(COMMA, expr) COMMA? RBRACE { $3 }
expr_list_or_seq_expr:
| expr_list { $1 }
| seq_expr(SEMI) { [$1] };
(* The grammar of simple exprs changes slightly according to context:
* - in most cases, calls (like f(x)) are allowed
* - in some contexts, calls are forbidden
* (most notably JSX lists and rhs of a SHARPOP extension).
*
* simple_expr_template contains the generic parts,
* simple_expr, simple_expr_no_call and simple_expr_no_constructor the specialized instances.
*)
%inline simple_expr_template(E):
| as_loc(val_longident) { mkexp (Pexp_ident $1) }
| constant
{ let attrs, cst = $1 in mkexp ~attrs (Pexp_constant cst) }
| jsx { $1 }
| simple_expr_direct_argument { $1 }
| array_expr_list
{ mkexp (Pexp_array $1) }
(* Not sure why this couldn't have just been below_SHARP (Answer: Being
* explicit about needing to wait for "as") *)
| as_loc(constr_longident) %prec prec_constant_constructor
{ mkexp (Pexp_construct ($1, None)) }
| name_tag %prec prec_constant_constructor
{ mkexp (Pexp_variant ($1, None)) }
| LPAREN expr_list RPAREN
{ may_tuple $startpos $endpos $2 }
| E as_loc(POSTFIXOP)
{ mkexp(Pexp_apply(mkoperator $2, [Nolabel, $1])) }
| od=open_dot_declaration DOT LPAREN expr_list_or_seq_expr RPAREN
{
let loc = mklocation $symbolstartpos $endpos in
let openSyntaxNotationAttribute = {
Ppxlib.attr_name = mkloc "reason.openSyntaxNotation" loc;
attr_payload = PStr [];
attr_loc = Location.none
} in
mkexp ~attrs:[openSyntaxNotationAttribute] (Pexp_open(od, may_tuple $startpos($3) $endpos($5) $4)) }
| E DOT as_loc(label_longident)
{ mkexp(Pexp_field($1, $3)) }
| od=open_dot_declaration DOT LBRACE RBRACE
{ let loc = mklocation $symbolstartpos $endpos in
let pat = mkpat (Ppat_var (mkloc "this" loc)) in
mkexp(Pexp_open (od, mkexp(Pexp_object(Ast_helper.Cstr.mk pat []))))
}
| E LBRACKET expr RBRACKET
{ let loc = mklocation $symbolstartpos $endpos in
let exp = Ppxlib.Pexp_ident(array_function ~loc "Array" "get") in
mkexp(Pexp_apply(mkexp ~ghost:true ~loc exp, [Nolabel,$1; Nolabel,$3]))
}
| E DOT LBRACKET expr RBRACKET
{ let loc = mklocation $symbolstartpos $endpos in
let exp = Ppxlib.Pexp_ident(array_function ~loc "String" "get") in
mkexp(Pexp_apply(mkexp ~ghost:true ~loc exp, [Nolabel,$1; Nolabel,$4]))
}
| E bigarray_access
{ let loc = mklocation $symbolstartpos $endpos in
bigarray_get ~loc $1 $2 }
| od=open_dot_declaration DOT LBRACE record_expr RBRACE
{ let loc = mklocation $symbolstartpos $endpos in
mkexp(Pexp_open(od, mk_record_expr ~loc $4))
}
| od=open_dot_declaration DOT LBRACE record_expr_with_string_keys RBRACE
{ let (exten, fields) = $4 in
let loc = mklocation $symbolstartpos $endpos in
let rec_exp = mkexp ~loc (Pexp_extension (mkloc ("mel.obj") loc,
PStr [mkstrexp (mkexp ~loc (Pexp_record(fields, exten))) []]))
in
mkexp(Pexp_open(od, rec_exp))
}
| od=open_dot_declaration DOT LBRACKETBAR expr_list BARRBRACKET
{ let loc = mklocation $symbolstartpos $endpos in
let rec_exp = Ast_helper.Exp.mk ~loc ~attrs:[] (Pexp_array $4) in
mkexp(Pexp_open(od, rec_exp))
}
(* Parse Module.[<Component> <div/> </Component>] *)
| od=open_dot_declaration DOT LBRACKETLESS jsx_without_leading_less RBRACKET
{ let seq, ext_opt = [$4], None in
let loc = mklocation $startpos($4) $endpos($4) in
let list_exp = make_real_exp (mktailexp_extension loc seq ext_opt) in
let list_exp = { list_exp with pexp_loc = loc } in
mkexp (Pexp_open (od, list_exp))
}
| od=open_dot_declaration DOT LBRACKET RBRACKET
{ let loc = mklocation $startpos($3) $endpos($4) in
let list_exp = make_real_exp (mktailexp_extension loc [] None) in
let list_exp = { list_exp with pexp_loc = loc } in
mkexp (Pexp_open (od, list_exp))
}
| od=open_dot_declaration DOT LBRACKET expr_comma_seq_extension RBRACKET
{ let seq, ext_opt = $4 in
let loc = mklocation $startpos($4) $endpos($4) in
let list_exp = make_real_exp (mktailexp_extension loc seq ext_opt) in
let list_exp = { list_exp with pexp_loc = loc } in
mkexp (Pexp_open (od, list_exp))
}
| as_loc(PREFIXOP) E %prec below_DOT_AND_SHARP
{ mkexp(Pexp_apply(mkoperator $1, [Nolabel, $2])) }
(**
* Must be below_DOT_AND_SHARP so that the parser waits for several dots for
* nested record access that the bang should apply to.
*
* !x.y.z should be parsed as !(((x).y).z)
*)
(*| as_loc(BANG {"!"}) E %prec below_DOT_AND_SHARP
{ mkexp (Pexp_apply(mkoperator $1, [Nolabel,$2])) }*)
| NEW as_loc(class_longident)
{ mkexp (Pexp_new $2) }
| od=open_dot_declaration DOT LBRACELESS field_expr_list COMMA? GREATERRBRACE
{ let loc = mklocation $symbolstartpos $endpos in
let exp = Ast_helper.Exp.mk ~loc ~attrs:[] (Pexp_override $4) in
mkexp (Pexp_open(od, exp))
}
| E SHARP as_loc(label)
{ mkexp (Pexp_send($1, $3)) }
| E as_loc(SHARPOP) simple_expr_no_call
{ mkinfixop $1 (mkoperator $2) $3 }
| E as_loc(SHARPEQUAL) simple_expr
{ let op = { $2 with txt = "#=" } in
mkinfixop $1 (mkoperator op) $3 }
| E as_loc(MINUSGREATER) simple_expr_no_call
{ mkinfixop $1 (mkoperator {$2 with txt = "|."}) $3 }
| extension
{ mkexp (Pexp_extension $1) }
;
%inline simple_expr: simple_expr_call { mkexp_app_rev $startpos $endpos $1 };
simple_expr_no_constructor [@recover.expr default_expr ()]:
mark_position_exp(simple_expr_template(simple_expr_no_constructor)) { $1 };
simple_expr_template_constructor:
| as_loc(constr_longident)
mark_position_exp
( non_labeled_argument_list { mkexp (Pexp_tuple($1)) }
| simple_expr_direct_argument { $1 }
)
{ mkExplicitArityTupleExp (Pexp_construct($1, Some $2))
}
| name_tag
mark_position_exp
( non_labeled_argument_list
{ (* only wrap in a tuple if there are more than one arguments *)
match $1 with
| [x] -> x
| l -> mkexp (Pexp_tuple(l))
}
| simple_expr_direct_argument { $1 }
)
{ mkexp(Pexp_variant($1, Some $2)) }
;
simple_expr_no_call [@recover.expr default_expr ()]:
| mark_position_exp(simple_expr_template(simple_expr_no_call)) { $1 }
| simple_expr_template_constructor { $1 }
;
simple_expr_call [@recover.expr (default_expr (), [])]:
| mark_position_exp(simple_expr_template(simple_expr)) { ($1, []) }
| simple_expr_call labeled_arguments
{ let (body, args) = $1 in
(body, List.rev_append $2 args) }
| LBRACKET expr_comma_seq_extension RBRACKET
{ let seq, ext_opt = $2 in
let loc = mklocation $startpos($2) $endpos($2) in
(make_real_exp (mktailexp_extension loc seq ext_opt), [])
}
| simple_expr_template_constructor { ($1, []) }
;
simple_expr_direct_argument:
(*
Because [< is a special token, the <ident and <> won't be picked up as separate
tokens, when a list begins witha JSX tag. So we special case it.
(todo: pick totally different syntax for polymorphic variance types to avoid
the issue alltogether.
first token
/\
[<ident args /> , remainingitems ]
[<> , remainingitems ]
*)
| braced_expr { $1 }
| LBRACKETLESS jsx_without_leading_less COMMA expr_comma_seq_extension RBRACKET
{ let entireLoc = mklocation $startpos($1) $endpos($4) in
let (seq, ext_opt) = $4 in
mktailexp_extension entireLoc ($2::seq) ext_opt
}
| LBRACKETLESS jsx_without_leading_less RBRACKET
{ let entireLoc = mklocation $startpos($1) $endpos($3) in
mktailexp_extension entireLoc ($2::[]) None
}
| LBRACKETLESS jsx_without_leading_less COMMA RBRACKET
{ let entireLoc = mklocation $startpos($1) $endpos($4) in
mktailexp_extension entireLoc [$2] None
}
| LBRACELESS field_expr_list COMMA? GREATERRBRACE
{ mkexp (Pexp_override $2) }
| LBRACELESS GREATERRBRACE
{ mkexp (Pexp_override [])}
| LPAREN MODULE module_expr RPAREN
{ mkexp (Pexp_pack $3) }
| LPAREN MODULE module_expr COLON package_type RPAREN
{ let loc = mklocation $symbolstartpos $endpos in
mkexp (Pexp_constraint (mkexp ~ghost:true ~loc (Pexp_pack $3), $5))
}
;
%inline non_labelled_expr_comma_list:
lseparated_nonempty_list(COMMA, expr_optional_constraint) COMMA? { $1 };
non_labeled_argument_list:
| parenthesized(non_labelled_expr_comma_list) { $1 }
| LPAREN RPAREN
{ let loc = mklocation $startpos $endpos in
[mkexp_constructor_unit loc loc] }
;
%inline labelled_expr_comma_list:
lseparated_list(COMMA, uncurried_labeled_expr) COMMA? { $1 };
labeled_arguments:
| mark_position_exp(simple_expr_direct_argument)
{ [(Nolabel, $1)] }
| parenthesized(labelled_expr_comma_list)
{ match $1 with
| [] -> let loc = mklocation $startpos $endpos in
[(Nolabel, mkexp_constructor_unit loc loc)]
| xs -> xs
}
| LPAREN DOT RPAREN
{ let loc = mklocation $startpos $endpos in
[(Nolabel, mkexp_constructor_unit ~uncurried:true loc loc)]
}
;
labeled_expr_constraint:
| expr_optional_constraint { fun _punned -> $1 }
| type_constraint
{ fun punned ->
let exp = mkexp (Pexp_ident punned) ~loc:punned.loc in
match $1 with
| typ ->
let loc = mklocation punned.loc.loc_start $endpos in
ghexp_constraint loc exp typ
}
;
%inline uncurried_labeled_expr:
| DOT? labeled_expr {
let uncurried = match $1 with | Some _ -> true | None -> false in
if uncurried then
let (lbl, (argExpr: Ppxlib.expression)) = $2 in
let loc = mklocation $startpos $endpos in
let up = uncurry_payload ~name:"uncurry" loc in
(lbl, {argExpr with pexp_attributes = up::argExpr.pexp_attributes})
else $2
}
;
longident_type_constraint:
| as_loc(val_longident) type_constraint?
{ $1, $2 }
labeled_expr:
| expr_optional_constraint { (Nolabel, $1) }
| TILDE as_loc(either(parenthesized(longident_type_constraint), longident_type_constraint))
{ (* add(~a, ~b) -> parses ~a & ~b *)
let lident_loc, maybe_typ = $2.txt in
let exp = mkexp (Pexp_ident lident_loc) ~loc:lident_loc.loc in
let labeled_exp = match maybe_typ with
| None -> exp
| Some typ ->
ghexp_constraint $2.loc exp typ
in
(Labelled (Ppxlib.Longident.last_exn lident_loc.txt), labeled_exp)
}
| TILDE as_loc(val_longident) QUESTION
{ (* foo(~a?) -> parses ~a? *)
let exp = mkexp (Pexp_ident $2) ~loc:$2.loc in
(Optional (Ppxlib.Longident.last_exn $2.txt), exp)
}
| TILDE as_loc(LIDENT) EQUAL optional labeled_expr_constraint
{ (* foo(~bar=?Some(1)) or add(~x=1, ~y=2) -> parses ~bar=?Some(1) & ~x=1 & ~y=1 *)
($4 $2.txt, $5 { $2 with txt = Lident $2.txt })
}
| TILDE as_loc(LIDENT) EQUAL optional as_loc(UNDERSCORE)
{ (* foo(~l =_) *)
let loc = $5.loc in
let exp = mkexp (Pexp_ident (mkloc (Ppxlib.Longident.Lident "_") loc)) ~loc in
($4 $2.txt, exp)
}
| as_loc(UNDERSCORE)
{ (* foo(_) *)
let loc = $1.loc in
let exp = mkexp (Pexp_ident (mkloc (Ppxlib.Longident.Lident "_") loc)) ~loc in
(Nolabel, exp)
}
;
%inline and_let_binding:
(* AND bindings don't accept a preceeding extension ID, but do accept
* preceeding attribute*. These preceeding attribute* will cause an
* error if this is an *expression * let binding. Otherwise, they become
* attribute* on the structure item for the "and" binding.
*)
item_attributes AND let_binding_body
{ let pat, expr, ct = $3 in
Ast_helper.Vb.mk ?value_constraint:ct ~loc:(mklocation $symbolstartpos $endpos) ~attrs:$1 pat expr }
;
let_bindings: let_binding and_let_binding* { addlbs $1 $2 };
let_binding:
(* Form with item extension sugar *)
item_attributes LET item_extension_sugar? rec_flag let_binding_body
{ let loc = mklocation $symbolstartpos $endpos in
let pat, expr, ct = $5 in
mklbs $3 $4 (Ast_helper.Vb.mk ~loc ~attrs:$1 ?value_constraint:ct pat expr) loc }
;
let_binding_body:
| simple_pattern_ident type_constraint EQUAL expr
{ let t =
match $2 with
Some t, None ->
Ppxlib.Pvc_constraint { locally_abstract_univars = []; typ=t }
| ground, Some coercion -> Pvc_coercion { ground; coercion}
| _ -> assert false
in
($1, $4, Some t) }
| simple_pattern_ident fun_def(EQUAL,core_type)
{ ($1, $2, None) }
| simple_pattern_ident COLON as_loc(preceded(QUOTE,ident))+ DOT core_type
EQUAL mark_position_exp(expr)
{ let typ = mktyp ~ghost:true (Ptyp_poly($3, $5)) in
($1, $7, Some (Ppxlib.Pvc_constraint { locally_abstract_univars = []; typ }))
}
| simple_pattern_ident COLON TYPE as_loc(LIDENT)+ DOT core_type
EQUAL mark_position_exp(expr)
(* Because core_type will appear to contain "type constructors" since the
* type variables listed in LIDENT+ don't have leading single quotes, we
* have to call [varify_constructors] (which is what [wrap_type_annotation]
* does among other things) to turn those "type constructors" that correspond
* to LIDENT+ into regular type variables. I don't think this should be
* done in the parser!
*)
(* In general, this is a very strange transformation that occurs in the
* standard OCaml parser, but producing the same strange transformation, and
* being able to recover original code from the result has the benefit that
* this syntax will integrate seamlessly with ASTs produced by the standard
* OCaml parser.
*
* let s : type a . core_type = body
*
* LET_BINDING:
* Ppat_constraint(Ppat_var s, Ptyp_poly(newtypes, varified_core_type))
* Pexp_newtype..(a, Pexp_constraint(body, NOT_varified_core_type))
*
* When [a] is in the first arg to [PTyp_poly] the second arg [core_type]
* expects to see [a] and ['a] is not allowed anywhere.
* When pretty printing, we must reverse this entire process!
*
* All of this is consistent with the Manual which states:
*
* let rec f : type t1 t2. t1 * t2 list -> t1 = ...
*
* is automatically expanded into
*
* let rec f : 't1 't2. 't1 * 't2 list -> 't1 =
* fun (type t1) (type t2) -> (... : t1 * t2 list -> t1)
*
* So therefore we end up generating the following two forms of parse trees
* for the two primary forms of explicitly polymorphic type annotations:
*
*
* /-----------Ppat_constraint--------\ /-PExp_constraint--\
* let x: locallyAbstractTypes . typeVars = exp
*
* or
* /-------------Ppat_constraint-----------\ /----PExp_constraint------\
* let x: type abstractTypes . varified_core_type = (exp : core_type_non_varified)
* where carified_core_type must equal (varify_constructors core_type_non_varified)
*
* And in the later case
*
*)
{ ($1, $8, Some (Pvc_constraint { locally_abstract_univars = $4; typ=$6 })) }
(* The combination of the following two rules encompass every type of
* pattern *except* val_identifier. The fact that we want handle the
* val_ident separately as a separate rule in let_binding_body alone justifies the
* need for the strange structuring of
* [pattern]/[simple_pattern_not_ident]/[simple_pattern] - it allows us
* to isolate [val_ident] in the special case of [let_binding_body].
*
* TODO:
* Unfortunately, it means we cannot do: let (myCurriedFunc: int -> int) a -> a;
*)
| pattern EQUAL expr
{ ($1, $3, None) }
| simple_pattern_not_ident COLON core_type EQUAL expr
{ let t =
Ppxlib.Pvc_constraint { locally_abstract_univars = []; typ=$3 }
in
($1, $5, Some t)
}
;
letop_binding_body:
| pat = simple_pattern_ident exp = expr
{ (pat, exp) }
| pat = simple_pattern COLON typ = core_type EQUAL exp = expr
{ let loc = mklocation $startpos(pat) $endpos(typ) in
(mkpat ~ghost:true ~loc (Ppat_constraint(pat, typ)), exp) }
| pat = pattern EQUAL exp = expr
{ (pat, exp) }
;
letop_bindings:
body = letop_binding_body
{ let let_pat, let_exp = body in
let_pat, let_exp, [] }
| bindings = letop_bindings pbop_op = as_loc(ANDOP) body = letop_binding_body
{ let let_pat, let_exp, rev_ands = bindings in
let pbop_pat, pbop_exp = body in
let pbop_loc = mklocation $symbolstartpos $endpos in
let and_ = {Ppxlib.pbop_op; pbop_pat; pbop_exp; pbop_loc} in
let_pat, let_exp, and_ :: rev_ands }
;
(*
* TODO:
* In OCaml, the following function binding would be parsed by the function
* parsers but would return a non function. Coincidentally, everything just worked.
* let x: int = 10;
* Since in Reason, function bindings always use arrows, it's wrong to rely
* on function parsers to return non function bindings:
* let x: int -> 10;
* let y (:returnType) -> 20; (* wat *)
*)
%inline match_cases(EXPR): lnonempty_list(match_case(EXPR)) { $1 };
match_case(EXPR):
| as_loc(BAR) pattern EQUALGREATER EXPR
{ let pat = {$2 with ppat_loc =
{ $2.ppat_loc with
loc_start = $1.loc.loc_start
}
} in
Ast_helper.Exp.case pat $4 }
| as_loc(BAR) pattern preceded(WHEN,expr) EQUALGREATER EXPR
{ let pat = {$2 with ppat_loc =
{ $2.ppat_loc with
loc_start = $1.loc.loc_start
}
} in
Ast_helper.Exp.case pat ~guard:$3 $5 }
| as_loc(BAR) pattern EQUALGREATER as_loc(DOT)
{
let pat = {
$2 with ppat_loc =
{ $2.ppat_loc with loc_start = $1.loc.loc_start }
} in
Ast_helper.Exp.(case pat (unreachable ~loc:$4.loc ()))
}
;
fun_def(DELIM, typ):
labeled_pattern_list
preceded(COLON,typ)?
either(preceded(DELIM, expr), braced_expr)
{ let loc = mklocation $startpos $endpos in
let (pl, uncurried) = $1 in
let exp = List.fold_right ~f:mkexp_fun pl
~init:(match $2 with
| None -> $3
| Some ct -> Ast_helper.Exp.constraint_ ~loc $3 ct)
in
if uncurried then
{exp with pexp_attributes = (uncurry_payload loc)::exp.pexp_attributes}
else exp
}
;
(* At least one comma delimited: Each item optionally annotated. *)
expr_list:
lseparated_nonempty_list(COMMA, expr_optional_constraint) COMMA?
{ $1 }
;
(* [x, y, z, ...n] --> ([x,y,z], Some n) *)
expr_comma_seq_extension:
lseparated_nonempty_list(COMMA, opt_spread(expr_optional_constraint)) COMMA?
{ match List.rev $1 with
(* Check if the last expr has been spread with `...` *)
| ((dotdotdot, e) as hd)::es ->
let (es, ext) = match dotdotdot with
| Some _ -> (es, Some e)
| None -> (hd::es, None)
in
let msg = "Lists can only have one `...` spread, at the end.
Explanation: lists are singly-linked list, where a node contains a value and points to the next node. `[a, ...bc]` efficiently creates a new item and links `bc` as its next nodes. `[...bc, a]` would be expensive, as it'd need to traverse `bc` and prepend each item to `a` one by one. We therefore disallow such syntax sugar.
Solution: directly use `concat` or other List helpers." in
let exprList = filter_raise_spread_syntax msg es in
(List.rev exprList, ext)
| [] -> [], None
}
;
(**
* See note about tuple patterns. There are few cases where expressions may be
* type constrained without requiring additional parens, and inside of tuples
* are one exception.
*)
expr_optional_constraint:
| expr { $1 }
| expr type_constraint
{ ghexp_constraint (mklocation $symbolstartpos $endpos) $1 $2 }
;
record_expr:
| DOTDOTDOT expr_optional_constraint lnonempty_list(preceded(COMMA,
opt_spread(lbl_expr))) COMMA?
{ let exprList = filter_raise_spread_syntax record_exp_spread_msg $3
in (Some $2, exprList)
}
| DOTDOTDOT
expr_optional_constraint SEMI
lseparated_nonempty_list(COMMA, opt_spread(lbl_expr)) COMMA?
{ raise_record_trailing_semi_error'
(mklocation $startpos($3) $endpos($3)) }
| DOTDOTDOT
expr_optional_constraint
lnonempty_list(preceded(COMMA, opt_spread(lbl_expr))) SEMI
{ raise_record_trailing_semi_error'
(mklocation $startpos($4) $endpos($4)) }
| non_punned_lbl_expr COMMA?
{ (None, [$1]) }
| non_punned_lbl_expr SEMI
{ raise_record_trailing_semi_error'
(mklocation $startpos($2) $endpos($2)) }
| lbl_expr lnonempty_list(preceded(COMMA, opt_spread(lbl_expr))) COMMA?
{ let exprList = filter_raise_spread_syntax record_exp_spread_msg $2 in
(None, $1 :: exprList) }
| lbl_expr lnonempty_list(preceded(COMMA, opt_spread(lbl_expr))) SEMI
{ raise_record_trailing_semi_error'
(mklocation $startpos($3) $endpos($3)) }
;
%inline non_punned_lbl_expr:
| as_loc(label_longident) COLON expr { ($1, $3) }
;
%inline punned_lbl_expr:
| as_loc(label_longident) { ($1, exp_of_label $1) }
;
%inline lbl_expr:
| non_punned_lbl_expr {$1}
| punned_lbl_expr {$1}
;
record_expr_with_string_keys:
| DOTDOTDOT expr_optional_constraint COMMA string_literal_exprs_maybe_punned
{ (Some $2, $4) }
| STRING COLON expr COMMA?
{ let loc = mklocation $symbolstartpos $endpos in
let (s, _, _) = $1 in
let lident_lident_loc = mkloc (Ppxlib.Longident.Lident s) loc in
(None, [(lident_lident_loc, $3)])
}
| string_literal_expr_maybe_punned_with_comma string_literal_exprs_maybe_punned {
(None, $1 :: $2)
}
;
string_literal_exprs_maybe_punned:
lseparated_nonempty_list(COMMA, string_literal_expr_maybe_punned) COMMA? { $1 };
(* Had to manually inline these two forms for some reason *)
string_literal_expr_maybe_punned_with_comma:
| STRING COMMA
{ let loc = mklocation $startpos $endpos in
let (s, _, _) = $1 in
let lident_lident_loc = mkloc (Ppxlib.Longident.Lident s) loc in
let exp = mkexp ~loc (Pexp_ident lident_lident_loc) in
(lident_lident_loc, exp)
}
| STRING COLON expr COMMA
{ let loc = mklocation $startpos $endpos in
let (s, _, _) = $1 in
let lident_lident_loc = mkloc (Ppxlib.Longident.Lident s) loc in
let exp = $3 in
(lident_lident_loc, exp)
}
;
string_literal_expr_maybe_punned:
STRING preceded(COLON, expr)?
{ let loc = mklocation $startpos $endpos in
let (s, _, _) = $1 in
let lident_lident_loc = mkloc (Ppxlib.Longident.Lident s) loc in
let exp = match $2 with
| Some x -> x
| None -> mkexp ~loc (Pexp_ident lident_lident_loc)
in
(lident_lident_loc, exp)
}
;
(**
* field_expr is distinct from record_expr because labels cannot/shouldn't be scoped.
*)
field_expr:
(* Using LIDENT instead of label here, because a reduce/reduce conflict occurs on:
* {blah:x}
*
* After `blah`, the parser couldn't tell whether to reduce `label` or
* `val_ident`. So inlining the terminal here to avoid the whole decision.
* Another approach would have been to place the `label` rule at a precedence
* of below_COLON or something.
*)
| as_loc(LIDENT) COLON expr
{ ($1, $3) }
| LIDENT
{ let loc = mklocation $symbolstartpos $endpos in
let lident_loc = mkloc $1 loc in
let lident_lident_loc = mkloc (Ppxlib.Longident.Lident $1) loc in
(lident_loc, mkexp (Pexp_ident lident_lident_loc))
}
;
%inline field_expr_list: lseparated_nonempty_list(COMMA, field_expr) { $1 };
(* Allows for Ptyp_package core types without parens in the context
* of a "type_constraint":
* let x: module Foo.Bar.Baz = (module FirstClass)
* ^^^^^^^^^^^^^^^^^^
*)
%inline module_constraint_type:
mark_position_typ (preceded(MODULE, package_type)) {$1}
;
type_constraint:
| COLON core_type
preceded(COLONGREATER,core_type)?
{ (Some $2, $3) }
| COLONGREATER core_type
{ (None, Some $2) }
| COLON module_constraint_type
{ (Some $2, None) }
;
(* Patterns *)
pattern:
| pattern_without_or { $1 }
| mark_position_pat(pattern BAR pattern { mkpat(Ppat_or($1, $3)) }) { $1 }
;
%inline pat_comma_list:
lseparated_nonempty_list(COMMA, pattern_optional_constraint) COMMA? { $1 };
pattern_constructor_argument:
| simple_pattern_direct_argument
{ [$1] }
| parenthesized(pat_comma_list)
{ $1 }
;
(**
* Provides sugar for pattern matching on a constructor pattern with a 'direct' argument.
* Example:
* | Foo () => () is sugar for | Foo(()) => ()
* | Foo [a, b, c] => () is sugar for | Foo([a, b, c]) => ()
* | Foo [|x, y|] => () is sugar for | Foo([|x, y|]) => ()
* }
*)
simple_pattern_direct_argument:
mark_position_pat (
as_loc(constr_longident)
{ mkpat(Ppat_construct(mkloc $1.txt $1.loc, None)) }
| simple_delimited_pattern { $1 }
) {$1}
;
pattern_without_or:
mark_position_pat
( simple_pattern { $1 }
| pattern_without_or AS as_loc(val_ident)
{ mkpat(Ppat_alias($1, $3)) }
(**
* Parses a (comma-less) list of patterns into a tuple, or a single pattern
* (if there is only one item in the list). This is kind of sloppy as there
* should probably be a different AST construct for the syntax construct this
* is used in (multiple constructor arguments). The things passed to
* constructors are not actually tuples either in underlying representation or
* semantics (they are not first class).
*)
| as_loc(constr_longident) pattern_constructor_argument
(* the first case is `| Foo(_)` and doesn't need explicit_arity attached. Actually, something like `| Foo(1)` doesn't either, but we
keep explicit_arity on the latter anyways because why not. But for `| Foo(_)` in particular, it's convenient to have explicit_arity
removed, so that you can have the following shortcut:
| Foo _ _ _ _ _
vs.
| Foo _
*)
{ match is_pattern_list_single_any $2 with
| Some singleAnyPat ->
mkpat (Ppat_construct($1, Some ([], singleAnyPat)))
| None ->
let loc = mklocation $symbolstartpos $endpos in
let argPattern = simple_pattern_list_to_tuple ~loc $2 in
mkExplicitArityTuplePat (Ppat_construct($1, Some ([], argPattern)))
}
| name_tag simple_pattern { mkpat (Ppat_variant($1, Some $2)) }
| pattern_without_or as_loc(COLONCOLON) pattern_without_or
{ syntax_error $2.loc
":: is not supported in Reason, please use [hd, ...tl] instead";
let loc = mklocation $symbolstartpos $endpos in
mkpat_cons (mkpat ~ghost:true ~loc (Ppat_tuple[$1;$3])) loc
}
| LPAREN COLONCOLON RPAREN LPAREN pattern_without_or COMMA pattern_without_or RPAREN
{ let loc = mklocation $symbolstartpos $endpos in
mkpat_cons (mkpat ~ghost:true ~loc (Ppat_tuple[$5;$7])) loc
}
| EXCEPTION pattern_without_or %prec prec_constr_appl
{ mkpat(Ppat_exception $2) }
| LAZY simple_pattern { mkpat(Ppat_lazy $2) }
(**
* Attribute "attribute" everything to the left of the attribute,
* up until the point of to the start of an expression, left paren, left
* bracket, comma, bar - whichever comes first.
*)
| attribute pattern_without_or %prec attribute_precedence
{ {$2 with ppat_attributes = $1 :: $2.ppat_attributes} }
) {$1};
(* A "simple pattern" is either a value identifier, or it is a
* simple *non*value identifier.
*
* A "pattern" (the more general) is the set of all simple patterns,
* but also with:
* - more information such as `as X`, `lazy` etc.
*
* "labeled_simple_pattern"s contain the set of all simple_patterns, but also
* include patterns suitable in function bindings where labeled arguments are
* accepted.
*
* But, in all patterns, it seems type constraints must be grouped within some
* parens or something.
*)
simple_pattern:
| simple_pattern_ident
| simple_pattern_not_ident { $1 }
;
simple_pattern_ident:
as_loc(val_ident) { mkpat ~loc:$1.loc (Ppat_var $1) }
;
simple_pattern_not_ident:
mark_position_pat
( UNDERSCORE
{ mkpat (Ppat_any) }
| signed_constant
{ let attrs, cst = $1 in mkpat ~attrs (Ppat_constant cst) }
| signed_constant DOTDOT signed_constant
{ mkpat (Ppat_interval (snd $1, snd $3)) }
| signed_constant DOT signed_constant {
syntax_error (mklocation $startpos $endpos) "Constant ranges must be separated with spaces around the ..";
mkpat (Ppat_interval (snd $1, snd $3))
}
| as_loc(constr_longident)
{ mkpat (Ppat_construct ($1, None)) }
| name_tag
{ mkpat (Ppat_variant ($1, None)) }
| SHARP type_longident
{ mkpat (Ppat_type ($2)) }
| LPAREN lseparated_nonempty_list(COMMA, pattern_optional_constraint) COMMA? RPAREN
{ match $2 with
| [] -> (* This shouldn't be possible *)
let loc = mklocation $startpos $endpos in
mkpat_constructor_unit loc loc
| [hd] -> hd
| _ :: _ -> mkpat (Ppat_tuple $2)
}
| LPAREN MODULE as_loc(mod_ident) RPAREN
{ mkpat(Ppat_unpack($3)) }
| simple_pattern_not_ident_
{ $1 }
| extension
{ mkpat(Ppat_extension $1) }
) {$1};
simple_pattern_not_ident_:
| simple_delimited_pattern
{ $1 }
| as_loc(mod_longident) DOT simple_delimited_pattern
{ let loc = mklocation $symbolstartpos $endpos in
mkpat ~loc (Ppat_open ($1, $3))
}
| as_loc(mod_longident) DOT LPAREN pattern RPAREN
{ let loc = mklocation $symbolstartpos $endpos in
mkpat ~loc (Ppat_open ($1, $4)) }
| as_loc(mod_longident) DOT as_loc(LBRACKET RBRACKET {Ppxlib.Longident.Lident "[]"})
{ let loc = mklocation $symbolstartpos $endpos in
mkpat ~loc (Ppat_open($1, mkpat ~loc:$3.loc (Ppat_construct($3, None)))) }
| as_loc(mod_longident) DOT as_loc(LPAREN RPAREN {Ppxlib.Longident.Lident "()"})
{ let loc = mklocation $symbolstartpos $endpos in
mkpat ~loc (Ppat_open($1, mkpat ~loc:$3.loc (Ppat_construct($3, None)))) }
%inline simple_delimited_pattern:
| record_pattern { $1 }
| list_pattern { $1 }
| array_pattern { $1 }
%inline record_pattern:
LBRACE lbl_pattern_list RBRACE
{ let (fields, closed) = $2 in
let loc = mklocation $symbolstartpos $endpos in
mkpat ~loc (Ppat_record (fields, closed))
}
;
%inline list_pattern:
LBRACKET pattern_comma_list_extension RBRACKET
{ make_real_pat (mktailpat_extension (mklocation $startpos($2) $endpos($2)) $2) }
;
%inline array_pattern:
LBRACKETBAR loption(terminated(pattern_comma_list,COMMA?)) BARRBRACKET
{ mkpat (Ppat_array $2) }
;
pattern_optional_constraint:
mark_position_pat
( pattern { $1 }
| pattern COLON core_type
{ mkpat(Ppat_constraint($1, $3)) }
(* If we kill the `let module …` syntax, this can be placed inside pattern.
* Allows parsing of
* let foo = (type a, module X: X_t with type t = a) => X.a;
* ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
* The `module` keyword after the colon is optional, because `module X`
* clearly indicates that we're dealing with a Ppat_unpack here.
*)
| MODULE as_loc(mod_ident) COLON mark_position_typ(preceded(MODULE?, package_type))
{ mkpat (Ppat_constraint (mkpat (Ppat_unpack $2), $4)) }
) {$1};
;
%inline pattern_comma_list:
lseparated_nonempty_list(COMMA, opt_spread(pattern))
{ let msg = "Array's `...` spread is not supported in pattern matches.
Explanation: such spread would create a subarray; out of performance concern, our pattern matching currently guarantees to never create new intermediate data.
Solution: if it's to validate the first few elements, use a `when` clause + Array size check + `get` checks on the current pattern. If it's to obtain a subarray, use `Array.sub` or `Belt.Array.slice`." in
filter_raise_spread_syntax msg $1 };
(* [x, y, z, ...n] --> ([x,y,z], Some n) *)
pattern_comma_list_extension:
lseparated_nonempty_list(COMMA, opt_spread(pattern)) COMMA?
{ match List.rev $1 with
(* spread syntax is only allowed at the end *)
| ((dotdotdot, p) as hd)::ps ->
let (ps, spreadPat) = match dotdotdot with
| Some _ -> (ps, Some p)
| None -> (hd::ps, None)
in
let msg = "List pattern matches only supports one `...` spread, at the end.
Explanation: a list spread at the tail is efficient, but a spread in the middle would create new list(s); out of performance concern, our pattern matching currently guarantees to never create new intermediate data." in
let patList = filter_raise_spread_syntax msg ps in
(List.rev patList, spreadPat)
| [] -> [], None
};
;
_lbl_pattern_list:
| opt_spread(lbl_pattern) { ([$1], Closed) }
| opt_spread(lbl_pattern) COMMA { ([$1], Closed) }
| opt_spread(lbl_pattern) COMMA UNDERSCORE COMMA? { ([$1], Open) }
| opt_spread(lbl_pattern) COMMA _lbl_pattern_list
{ let (fields, closed) = $3 in $1 :: fields, closed }
;
%inline lbl_pattern_list:
_lbl_pattern_list
{ let (fields, closed) = $1 in
(filter_raise_spread_syntax record_pat_spread_msg fields, closed)
}
;
lbl_pattern:
| as_loc(label_longident) COLON pattern { ($1,$3) }
| as_loc(label_longident) { ($1, pat_of_label $1) }
| as_loc(label_longident) AS as_loc(val_ident)
{ (* punning with alias eg. {ReasonReact.state as prevState}
* -> {ReasonReact.state: state as prevState} *)
($1, mkpat(Ppat_alias(pat_of_label $1, $3)))
}
;
(* Primitive declarations *)
primitive_declaration: nonempty_list(STRING { let (s, _, _) = $1 in s }) {$1};
(* Type declarations
The rule for declaring multiple types, 'type t = ... and u = ...', is
written in a "continuation-passing-style". In pseudo-code:
Rather than having rules like:
(1) "TYPE one_type (AND one_type)*"
It looks like:
(2) "TYPE types" where "types = one_type (AND types)?".
This give more context to prevent ambiguities when parsing attributes.
Because attributes can appear before AND (1), the parser should
decide very early whether to reduce "one_type", so that an attribute can
get attached to AND.
Previously, only [@..] could occur inside "one_type" and only [@@...] before
AND. Now we only have [@..].
With style (2), we can inline the relevant part of "one_type"
(see type_declaration_kind) to parse attributes as needed and take a
decision only when arriving at AND.
*)
type_declarations:
item_attributes TYPE nonrec_flag type_declaration_details
{ let (ident, params, constraints, kind, priv, manifest), endpos, and_types = $4 in
let loc = mklocation $startpos($2) endpos in
let ty = Ast_helper.Type.mk ident ~params:params ~cstrs:constraints
~kind ~priv ?manifest ~attrs:$1 ~loc in
($3, ty :: and_types, loc, None)
}
| item_attributes TYPE item_extension_sugar nonrec_flag type_declaration_details
{ let (ident, params, constraints, kind, priv, manifest), endpos, and_types = $5 in
let loc = mklocation $startpos($2) endpos in
let ty = Ast_helper.Type.mk ident ~params:params ~cstrs:constraints
~kind ~priv ?manifest ~attrs:$1 ~loc in
($4, ty :: and_types, loc, Some $3)
}
;
and_type_declaration:
| { [] }
| item_attributes AND type_declaration_details
{ let (ident, params, cstrs, kind, priv, manifest), endpos, and_types = $3 in
let loc = mklocation $symbolstartpos endpos in
Ast_helper.Type.mk ident ~params ~cstrs ~kind ~priv ?manifest ~attrs:$1 ~loc
:: and_types
}
;
type_declaration_details:
| as_loc(UIDENT) type_variables_with_variance type_declaration_kind
{ syntax_error $1.loc
"a type name must start with a lower-case letter or an underscore";
let (kind, priv, manifest), constraints, endpos, and_types = $3 in
(($1, $2, constraints, kind, priv, manifest), endpos, and_types) }
| as_loc(LIDENT) type_variables_with_variance type_declaration_kind
{ let (kind, priv, manifest), constraints, endpos, and_types = $3 in
(($1, $2, constraints, kind, priv, manifest), endpos, and_types) }
;
type_declaration_kind:
| EQUAL private_flag constructor_declarations
{ let (cstrs, constraints, endpos, and_types) = $3 in
((Ptype_variant (cstrs), $2, None), constraints, endpos, and_types) }
| EQUAL core_type EQUAL private_flag constructor_declarations
{ let (cstrs, constraints, endpos, and_types) = $5 in
((Ptype_variant cstrs, $4, Some $2), constraints, endpos, and_types) }
| type_other_kind constraints and_type_declaration
{ ($1, $2, $endpos($2), $3) }
;
type_subst_kind:
| COLONEQUAL private_flag type_subst_constructor_declarations
{ let (cstrs, constraints, endpos, and_types) = $3 in
((Ptype_variant (cstrs), $2, None), constraints, endpos, and_types) }
| COLONEQUAL core_type EQUAL private_flag type_subst_constructor_declarations
{ let (cstrs, constraints, endpos, and_types) = $5 in
((Ppxlib.Ptype_variant cstrs, $4, Some $2), constraints, endpos, and_types) }
| type_subst_other_kind constraints and_type_subst_declaration
{ ($1, $2, $endpos($2), $3) }
;
type_subst_declarations:
item_attributes TYPE nrf=nonrec_flag name=as_loc(LIDENT)
params=type_variables_with_variance kind_priv_man=type_subst_kind
{ check_nonrec_absent (mklocation $startpos(nrf) $endpos(nrf)) nrf;
let (kind, priv, manifest), cstrs, endpos, and_types = kind_priv_man in
let ty =
Ast_helper.Type.mk name ~params ~cstrs ~kind ~priv
?manifest ~attrs:$1
~loc:(mklocation $symbolstartpos endpos)
in
ty :: and_types }
;
and_type_subst_declaration:
| { [] }
| item_attributes AND name=as_loc(LIDENT)
params=type_variables_with_variance kind_priv_man=type_subst_kind
{ let (kind, priv, manifest), cstrs, endpos, and_types = kind_priv_man in
Ast_helper.Type.mk name ~params ~cstrs
~kind ~priv ?manifest
~attrs:$1
~loc:(mklocation $symbolstartpos endpos)
:: and_types
}
;
%inline constraints:
| { [] }
| preceded(CONSTRAINT, constrain)+ { $1 }
;
type_subst_other_kind:
nonempty_type_other_kind(COLONEQUAL)
{ $1 }
type_other_kind:
| (*empty*)
{ (Ppxlib.Ptype_abstract, Public, None) }
| nonempty_type_other_kind(EQUAL)
{ $1 }
;
%inline nonempty_type_other_kind(eq_symbol):
| eq_symbol private_flag core_type
{ (Ppxlib.Ptype_abstract, $2, Some $3) }
| eq_symbol private_flag item_attributes record_declaration
{ (Ppxlib.Ptype_record (prepend_attrs_to_labels $3 $4), $2, None) }
| eq_symbol private_flag DOTDOT
{ (Ppxlib.Ptype_open, $2, None) }
| eq_symbol core_type EQUAL DOTDOT
{ (Ppxlib.Ptype_open, Public, Some $2) }
| eq_symbol core_type EQUAL private_flag item_attributes record_declaration
{ (Ppxlib.Ptype_record (prepend_attrs_to_labels $5 $6), $4, Some $2) }
;
type_variables_with_variance_comma_list:
lseparated_nonempty_list(COMMA, type_variable_with_variance) COMMA? {$1}
;
type_variables_with_variance:
| loption(parenthesized(type_variables_with_variance_comma_list))
{ $1 }
(* No need to parse LESSIDENT here, because for
* type_variables_with_variance, you'll never have an identifier in any of
* the type parameters*)
| lessthangreaterthanized(type_variables_with_variance_comma_list)
{ $1 }
;
type_variable_with_variance:
embedded
( QUOTE ident { (mktyp (Ptyp_var $2) , (NoVariance, NoInjectivity) ) }
| UNDERSCORE { (mktyp (Ptyp_any) , (NoVariance, NoInjectivity) ) }
| PLUS QUOTE ident { (mktyp (Ptyp_var $3) , (Covariant, NoInjectivity) ) }
| PLUS UNDERSCORE { (mktyp (Ptyp_any) , (Covariant, NoInjectivity) ) }
| MINUS QUOTE ident { (mktyp (Ptyp_var $3) , (Contravariant, NoInjectivity)) }
| MINUS UNDERSCORE { (mktyp Ptyp_any , (Contravariant, NoInjectivity)) }
)
{ let (first: Ppxlib.core_type), second = $1 in
let ptyp_loc =
{first.ptyp_loc with loc_start = $symbolstartpos; loc_end = $endpos}
in
({first with ptyp_loc}, second)
}
;
type_parameter: type_variance type_variable { ($2, ($1, NoInjectivity)) };
type_variance:
| (* empty *) { NoVariance }
| PLUS { Covariant }
| MINUS { Contravariant }
;
type_variable:
mark_position_typ
(QUOTE ident { mktyp (Ptyp_var $2) })
{ $1 };
constructor_declarations:
| BAR and_type_declaration { ([], [], $endpos, $2) }
| either(constructor_declaration,bar_constructor_declaration)
constructor_declarations_aux
{ let (cstrs, constraints, endpos, and_types) = $2 in
($1 :: cstrs, constraints, endpos, and_types)
}
;
constructor_declarations_aux:
| bar_constructor_declaration constructor_declarations_aux
{ let (cstrs, constraints, endpos, and_types) = $2 in
($1 :: cstrs, constraints, endpos, and_types)
}
| constraints and_type_declaration
{ ([], $1, $endpos($1), $2) }
;
type_subst_constructor_declarations:
either(constructor_declaration,bar_constructor_declaration)
type_subst_constructor_declarations_aux
{ let (cstrs, constraints, endpos, and_types) = $2 in
($1 :: cstrs, constraints, endpos, and_types)
}
;
type_subst_constructor_declarations_aux:
| bar_constructor_declaration type_subst_constructor_declarations_aux
{ let (cstrs, constraints, endpos, and_types) = $2 in
($1 :: cstrs, constraints, endpos, and_types)
}
| constraints and_type_subst_declaration
{ ([], $1, $endpos($1), $2) }
;
bar_constructor_declaration:
item_attributes BAR constructor_declaration
{ {$3 with pcd_attributes = $1 @ $3.pcd_attributes} }
;
constructor_declaration:
item_attributes as_loc(constr_ident) generalized_constructor_arguments
{ let args, res = $3 in
let loc = mklocation $symbolstartpos $endpos in
Ast_helper.Type.constructor ~attrs:$1 $2 ~args ?res ~loc }
;
(* Why are there already attribute* on the extension_constructor_declaration? *)
str_exception_declaration:
item_attributes EXCEPTION
either(extension_constructor_declaration, extension_constructor_rebind)
{
let expr: Ppxlib.extension_constructor = $3 in
{ expr with pext_attributes = expr.pext_attributes @ $1}
}
;
sig_exception_declaration:
item_attributes EXCEPTION
extension_constructor_declaration
{ let decl =
let ext: Ppxlib.extension_constructor = $3 in
{ ext with pext_attributes = ext.pext_attributes @ $1}
in
Ast_helper.Te.mk_exception ~loc:decl.pext_loc decl
}
;
generalized_constructor_arguments:
constructor_arguments? preceded(COLON,core_type)?
{ ((match $1 with None -> Ppxlib.Pcstr_tuple [] | Some x -> x), $2) }
;
constructor_arguments_comma_list:
lseparated_nonempty_list(COMMA, core_type) COMMA? {$1}
;
constructor_arguments:
| object_record_type { Pcstr_tuple [$1] }
(* XXX(anmonteiro): parse both parenthesized and non-parenthesized record
* declaration for backwards compatibility. This could probably be removed
* in a later (major) version if properly documented. *)
| record_declaration { Pcstr_record $1 }
| parenthesized(record_declaration) { Pcstr_record $1 }
| parenthesized(constructor_arguments_comma_list)
{ Pcstr_tuple $1 }
;
record_label_declaration:
| item_attributes mutable_flag as_loc(LIDENT)
{ let loc = mklocation $symbolstartpos $endpos in
Ast_helper.Type.field $3 (mkct $3) ~attrs:$1 ~mut:$2 ~loc
}
| item_attributes mutable_flag as_loc(LIDENT) COLON poly_type
{ let loc = mklocation $symbolstartpos $endpos in
Ast_helper.Type.field $3 $5 ~attrs:$1 ~mut:$2 ~loc
}
;
record_declaration:
LBRACE lseparated_nonempty_list(COMMA, record_label_declaration) COMMA? RBRACE
{ $2 }
;
(* Type Extensions *)
str_type_extension:
attrs = item_attributes
TYPE
flag = nonrec_flag
ident = as_loc(itype_longident)
params = type_variables_with_variance
PLUSEQ priv = embedded(private_flag)
constructors =
attributed_ext_constructors(either(extension_constructor_declaration, extension_constructor_rebind))
{ if flag <> Recursive then
not_expecting $startpos(flag) $endpos(flag) "nonrec flag";
let loc = mklocation $startpos($2) $endpos in
(Ast_helper.Te.mk ~loc ~params ~priv ~attrs ident constructors, loc, None)
}
| attrs = item_attributes
TYPE
extension = item_extension_sugar
flag = nonrec_flag
ident = as_loc(itype_longident)
params = type_variables_with_variance
PLUSEQ priv = embedded(private_flag)
constructors =
attributed_ext_constructors(either(extension_constructor_declaration, extension_constructor_rebind))
{ if flag <> Recursive then
not_expecting $startpos(flag) $endpos(flag) "nonrec flag";
let loc = mklocation $startpos($2) $endpos in
(Ast_helper.Te.mk ~loc ~params ~priv ~attrs ident constructors, loc, Some extension)
}
;
sig_type_extension:
attrs = item_attributes
TYPE
flag = nonrec_flag
ident = as_loc(itype_longident)
params = type_variables_with_variance
PLUSEQ priv = embedded(private_flag)
constructors =
attributed_ext_constructors(extension_constructor_declaration)
{ if flag <> Recursive then
not_expecting $startpos(flag) $endpos(flag) "nonrec flag";
let loc = mklocation $startpos($2) $endpos in
(Ast_helper.Te.mk ~params ~priv ~attrs ident constructors, loc, None)
}
| attrs = item_attributes
TYPE
extension = item_extension_sugar
flag = nonrec_flag
ident = as_loc(itype_longident)
params = type_variables_with_variance
PLUSEQ priv = embedded(private_flag)
constructors =
attributed_ext_constructors(extension_constructor_declaration)
{ if flag <> Recursive then
not_expecting $startpos(flag) $endpos(flag) "nonrec flag";
let loc = mklocation $startpos($2) $endpos in
(Ast_helper.Te.mk ~params ~priv ~attrs ident constructors, loc, Some extension)
}
;
%inline attributed_ext_constructor(X):
item_attributes BAR item_attributes X { {$4 with pext_attributes = List.concat [$1; $3; $4.pext_attributes]} }
(* Why is item_attributes duplicated?
To be consistent with attributes on (poly)variants/gadts.
So we can place the attribute after the BAR.
Example:
type water +=
pri
| [@foo] MineralWater;
*)
;
attributed_ext_constructors(X):
| X attributed_ext_constructor(X)* { $1 :: $2 }
| attributed_ext_constructor(X)+ { $1 }
;
extension_constructor_declaration:
as_loc(constr_ident) generalized_constructor_arguments
{ let args, res = $2 in
let loc = mklocation $symbolstartpos $endpos in
Ast_helper.Te.decl $1 ~args ?res ~loc
}
;
extension_constructor_rebind:
as_loc(constr_ident) EQUAL as_loc(constr_longident)
{ let loc = mklocation $symbolstartpos $endpos in
Ast_helper.Te.rebind $1 $3 ~loc
}
;
(* "with" constraints (additional type equations over signature components) *)
with_constraint:
| TYPE as_loc(label_longident) type_variables_with_variance
EQUAL embedded(private_flag) core_type constraints
{ let loc = mklocation $symbolstartpos $endpos in
let typ = Ast_helper.Type.mk {$2 with txt=Ppxlib.Longident.last_exn $2.txt}
~params:$3 ~cstrs:$7 ~manifest:$6 ~priv:$5 ~loc in
Pwith_type ($2, typ)
}
(* used label_longident instead of type_longident to disallow
functor applications in type path *)
| TYPE as_loc(label_longident) type_variables_with_variance
COLONEQUAL core_type
{ let last = match $2.txt with
| Ppxlib.Longident.Lident s -> s
| other ->
not_expecting $startpos($2) $endpos($2) "Long type identifier";
let rec fallback = function
| Ppxlib.Longident.Lident s -> s
| Ldot (_, s) -> s
| Lapply (l, _) -> fallback l
in
fallback other
in
let loc = mklocation $symbolstartpos $endpos in
Pwith_typesubst ($2, Ast_helper.Type.mk {$2 with txt=last} ~params:$3 ~manifest:$5 ~loc)
}
| MODULE as_loc(mod_longident) EQUAL as_loc(mod_ext_longident)
{ Pwith_module ($2, $4) }
| MODULE as_loc(UIDENT) COLONEQUAL as_loc(mod_ext_longident)
{ let lident = {$2 with txt=Ppxlib.Longident.Lident $2.txt} in
Pwith_modsubst (lident, $4) }
| MODULE TYPE as_loc(mty_longident) EQUAL module_type
{ Ppxlib.Pwith_modtype ($3, $5) }
| MODULE TYPE as_loc(mty_longident) COLONEQUAL module_type
{ Ppxlib.Pwith_modtypesubst ($3, $5) }
;
(* Polymorphic types *)
poly_type:
mark_position_typ
( core_type
{ $1 }
| as_loc(preceded(QUOTE,ident))+ DOT core_type
{ mktyp(Ptyp_poly($1, $3)) }
) {$1};
(**
* OCaml types before:
* -------------------
* core_type ::=
* core_type2
* core_type2 as ident
*
* core_type2 ::=
* simple_core_type_or_tuple
* ?ident: core_type2 -> core_type2
* ?ident: core_type2 -> core_type2
* ident: core_type2 -> core_type2
* core_type2 -> core_type2
*
* simple_core_type_or_tuple ::=
* simple_core_type
* simple_core_type * simple_core_type_list (*Reason deprecates this*)
*
* simple_core_type_list ::= (*Reason might be able to deprecate this*)
* simple_core_type
* simple_core_type_list STAR simple_core_type
*
* simple_core_type ::=
* simple_core_type
* simple_core_type2
* ( core_type) (*core_type_comma_list of len 1*)
*
* simple_core_type2 ::=
* 'ident
* Long.ident
* simple_core_type2 Long.ident
* (core_type, core_type) Long.ident
* <method1: ... method_2: ...>
* <>
* {method1: .. method2: ..}
* # class_longident #
* simple_core_type2 # class_longident
* (core_type, core_type) # class_longident
* (module package_type)
* [%]
* bunch of other stuff
*
* Reason types where tuples require grouping:
* -------------------
* Simple types are implicitly non-arrowed.
* Non arrowed types may be shown in the trailing positino of the curried sugar
* function/functor bindings, but it doesn't have to be simple.
*
* let x ... :non_arrowed_core_type => ..
*
* - A better name for core_type2 would be arrowed_core_type
* - A better name for core_type would be aliased_arrowed_core_type
* core_type ::=
* core_type2
* core_type2 as ident
*
* core_type2 ::=
* non_arrowed_core_type
* ident::? non_arrowed_core_type => non_arrowed_core_type
* ident:: non_arrowed_core_type => non_arrowed_core_type
* core_type2 => core_type2
*
* non_arrowed_core_type ::=
* non_arrowed_non_simple_core_type
* simple_core_type
*
* non_arrowed_non_simple_core_type ::=
* type_longident non_arrowed_simple_core_type_list
* # class_longident
* simple_core_type # class_longident
* [core_type_comma_list] # class_longident
*
* simple_core_type ::=
* <>
* ()
* {}
*
*
* 'ident
* Long.ident
* simple_core_type Long.ident
* Long.ident non_arrowed_simple_core_type_list
* <method1: ... method_2: ...>
* <>
* {method1: .. method2: ..}
* # class_longident #
* simple_core_type # class_longident
* (core_type, core_type) # class_longident
* (module package_type)
* [%]
* bunch of other stuff
*)
(** Potentially includes:
* - arrows
* - space separated type applications
* - "as" aliases
*)
core_type:
mark_position_typ
(* For some reason, when unifying Functor type syntax (using EQUALGREATER),
* there was a shift reduce conflict likely caused by
* type module MyFunctor = {type x = blah => foo } => SomeSig
* That should *not* be a shift reduce conflict (on =>), and it's not clear
* why the shift reduce conflict showed up in core_type2. Either way, this
* seems to resolve the issue. If removing the below_EQUALGREATER, the shift
* reduce conflict is actually caused by the new Functor type annotations
* even though *nothing* will point towards that.
* If switching to Menhir, this may not be needed.
*)
(
core_type2
{ $1 }
| core_type2 AS QUOTE as_loc(ident)
{ mktyp(Ptyp_alias($1, $4)) }
) {$1};
(**
*
* core_type is basically just core_type2 but with a single AS x potentially
* appended.
* core_type2 Potentially includes:
* - arrows
* - space separated type applications
* - Polymorphic type variable application
*)
core_type2:
item_attributes ct = unattributed_core_type
{ match $1 with
| [] -> ct
| attrs ->
let loc_start = $symbolstartpos and loc_end = $endpos in
let ptyp_loc = {ct.ptyp_loc with loc_start; loc_end} in
let ptyp_attributes = attrs @ ct.ptyp_attributes in
{ct with ptyp_attributes; ptyp_loc}
}
;
unattributed_core_type:
| non_arrowed_simple_core_type { $1 }
| arrowed_simple_core_type { $1 }
;
(* arrowed: because it contains =>
* simple: it doesn't need to be wrapped in parens *)
arrowed_simple_core_type:
| ES6_FUN arrow_type_parameters EQUALGREATER core_type2
{ List.fold_right ~f:mktyp_arrow $2 ~init:$4 }
| as_loc(labelled_arrow_type_parameter_optional) EQUALGREATER core_type2
{ mktyp_arrow ($1, false) $3 }
| basic_core_type EQUALGREATER core_type2
{ mktyp (Ptyp_arrow (Nolabel, $1, $3)) }
;
labelled_arrow_type_parameter_optional:
| TILDE LIDENT COLON protected_type EQUAL optional
{ ($6 $2, $4) }
;
arrow_type_parameter:
| protected_type { (Nolabel, $1) }
| TILDE LIDENT COLON protected_type
{ (Labelled $2, $4) }
| labelled_arrow_type_parameter_optional { $1 }
;
%inline uncurried_arrow_type_parameter:
DOT? as_loc(arrow_type_parameter)
{ let uncurried = match $1 with | Some _ -> true | None -> false in
($2, uncurried)
}
%inline arrow_type_parameter_comma_list:
| lseparated_nonempty_list(COMMA, uncurried_arrow_type_parameter) COMMA? {$1}
arrow_type_parameters:
| LPAREN arrow_type_parameter_comma_list RPAREN { $2 }
;
(* Among other distinctions, "simple" core types can be used in Variant types:
* type myType = Count of anySimpleCoreType. Core types (and simple core types)
* don't include variant declarations (`constructor_declarations`) and don't
* include the "faux curried" variant Constructor arguments list.
*
* In general, "simple" syntax constructs, don't need to be wrapped in
* parens/braces when embedded in lists of those very constructs.
*
* A [simple_core_type] *can* be wrapped in parens, but
* it doesn't have to be.
*)
(* The name [core_type] was taken. [non_arrowed_core_type] is the same as
* [simple_core_type] but used in cases
* where application needn't be wrapped in additional parens *)
(* Typically, other syntax constructs choose to allow either
* [simple_core_type] or
* [non_arrowed_non_simple_core_type] depending on whether or not
* they are in a context that expects space separated lists of types to carry
* particular meaning outside of type constructor application.
*
* type x = SomeConstructor x y;
*)
non_arrowed_core_type:
| non_arrowed_simple_core_type
{ $1 }
| attribute non_arrowed_core_type
{ {$2 with ptyp_attributes = $1 :: $2.ptyp_attributes} }
;
%inline type_parameter_comma_list:
| lseparated_nonempty_list(COMMA, protected_type) COMMA? {$1}
;
%inline first_less_than_type_ident:
LESSIDENT { Ppxlib.Longident.Lident $1 }
(* Since the <xyz token is parsed as a single token we need to catch that case here *)
%inline first_less_than_type_param:
mark_position_typ
( as_loc(first_less_than_type_ident)
{ mktyp(Ptyp_constr($1, [])) }
| as_loc(first_less_than_type_ident) type_parameters
{ mktyp(Ptyp_constr($1, $2)) }
) { $1 }
type_parameters:
| parenthesized(type_parameter_comma_list) { $1 }
| lessthangreaterthanized(type_parameter_comma_list) { $1 }
| first_less_than_type_param COMMA? GREATER { [$1] }
| first_less_than_type_param COMMA type_parameter_comma_list GREATER
{
$1 :: $3
}
;
(* "protected" stands for an environment where non-simple grammar
* is actually simple. non-simple => parens, simple => no-parens necessary
* For examples, in lists the ( and ) combined with , form a "protected"
* environment for non-simple types.
* in tuples: (int, string, float) ||-> int, string, float are protected
* in functions args: (int, string) => float ||-> int, string are protected *)
protected_type:
| module_constraint_type | core_type { $1 }
;
non_arrowed_simple_core_types:
mark_position_typ
( type_parameters
{ match $1 with
| [one] -> one
| many -> mktyp (Ptyp_tuple many)
}
) {$1};
non_arrowed_simple_core_type:
| non_arrowed_simple_core_types { $1 }
| mark_position_typ(basic_core_type) { $1 }
;
basic_core_type:
mark_position_typ
( type_longident type_parameters
{ mktyp(Ptyp_constr($1, $2)) }
| SHARP as_loc(class_longident) type_parameters
{ mktyp(Ptyp_class($2, $3)) }
| QUOTE ident
{ mktyp(Ptyp_var $2) }
| SHARP as_loc(class_longident)
{ mktyp(Ptyp_class($2, [])) }
| UNDERSCORE
{ mktyp(Ptyp_any) }
| type_longident
{ mktyp(Ptyp_constr($1, [])) }
| object_record_type
{ $1 }
| LBRACKETBAR row_field_list RBRACKET
| LBRACKET row_field_list RBRACKET
{ mktyp(Ptyp_variant ($2, Closed, None)) }
| LBRACKETGREATER loption(row_field_list) RBRACKET
{ mktyp(Ptyp_variant ($2, Open, None)) }
| LBRACKETLESS row_field_list loption(preceded(GREATER, name_tag+)) RBRACKET
{ mktyp(Ptyp_variant ($2, Closed, Some $3)) }
| extension
{ mktyp(Ptyp_extension $1) }
) {$1};
object_record_type:
| LBRACE RBRACE
{ let loc = mklocation $symbolstartpos $endpos in
syntax_error_typ loc "an object type cannot be empty" }
| LBRACE DOT string_literal_labels RBRACE
{ (* `{. "foo": bar}` -> `Js.t({. foo: bar})` *)
let loc = mklocation $symbolstartpos $endpos in
mkBsObjTypeSugar ~loc ~closed:Closed $3
}
| LBRACE DOTDOT string_literal_labels RBRACE
{ (* `{.. "foo": bar}` -> `Js.t({.. foo: bar})` *)
let loc = mklocation $symbolstartpos $endpos in
mkBsObjTypeSugar ~loc ~closed:Open $3
}
| LBRACE DOT loption(object_label_declarations) RBRACE
{ mktyp (Ptyp_object ($3, Closed)) }
| LBRACE DOTDOT loption(object_label_declarations) RBRACE
{ mktyp (Ptyp_object ($3, Open)) }
;
object_label_declaration:
| item_attributes as_loc(LIDENT)
{ Ast_helper.Of.tag ~attrs:$1 $2 (mkct $2) }
| item_attributes as_loc(LIDENT) COLON poly_type
{ Ast_helper.Of.tag ~attrs:$1 $2 $4 }
| DOTDOTDOT basic_core_type
{ Ast_helper.Of.inherit_ ~loc:(mklocation $symbolstartpos $endpos) $2 }
;
object_label_declarations:
lseparated_nonempty_list(COMMA, object_label_declaration) COMMA? { $1 };
string_literal_label:
item_attributes STRING COLON poly_type
{ let (label, _raw, _delim) = $2 in
let lblloc = mkloc label (mklocation $startpos($2) $endpos($2)) in
Ast_helper.Of.tag ~loc:(mklocation $symbolstartpos $endpos) ~attrs:$1 lblloc $4 }
;
string_literal_labels:
lseparated_nonempty_list(COMMA, string_literal_label) COMMA? { $1 };
package_type:
module_type
{ let loc = mklocation $startpos $endpos in
match package_type_of_module_type $1 with
| Some result -> mktyp ~loc (Ptyp_package result)
| None ->
syntax_error_typ $1.pmty_loc
"only module type identifier and 'with type' constraints are supported"
}
;
row_field_list:
| row_field bar_row_field* { $1 :: $2 }
| bar_row_field bar_row_field* { $1 :: $2 }
;
row_field:
| tag_field { $1 }
| non_arrowed_core_type
{ Ast_helper.Rf.inherit_ ~loc:(mklocation $symbolstartpos $endpos) $1 }
;
(* TODO::: *)
bar_row_field:
item_attributes BAR row_field
{ let loc = (mklocation $symbolstartpos $endpos) in
match $3.prf_desc with
| Rtag (name, amp, typs) ->
Ast_helper.Rf.tag ~loc ~attrs:($1 @ $3.prf_attributes) name amp typs
| Rinherit typ ->
Ast_helper.Rf.inherit_ ~loc { typ with ptyp_attributes = ($1 @ typ.ptyp_attributes) }
}
;
tag_field:
| item_attributes as_loc(name_tag)
boption(AMPERSAND)
separated_nonempty_list(AMPERSAND, non_arrowed_simple_core_types)
{ Ast_helper.Rf.tag ~loc:(mklocation $symbolstartpos $endpos) ~attrs:$1 $2 $3 $4 }
| item_attributes as_loc(name_tag)
{ Ast_helper.Rf.tag ~loc:(mklocation $symbolstartpos $endpos) ~attrs:$1 $2 true [] }
;
(* Constants *)
constant:
| INT { let (n, m) = $1 in ([], Pconst_integer (n, m)) }
| CHAR { ([], Pconst_char $1) }
| FLOAT { let (f, m) = $1 in ([], Pconst_float (f, m)) }
| as_loc(STRING) {
let { txt = (s, raw, d); loc } = $1 in
let attr = match raw with
| None -> []
| Some raw ->
let constant = Ast_helper.Exp.constant (Pconst_string (raw, loc, None)) in
[ { Ppxlib.attr_name = mkloc "reason.raw_literal" loc;
attr_payload = PStr [mkstrexp constant []];
attr_loc = Location.none
} ]
in
(attr, Pconst_string (s, loc, d))
}
;
signed_constant:
| constant { $1 }
| MINUS INT { let (n, m) = $2 in ([], Pconst_integer("-" ^ n, m)) }
| MINUS FLOAT { let (f, m) = $2 in ([], Pconst_float("-" ^ f, m)) }
| PLUS INT { let (n, m) = $2 in ([], Pconst_integer (n, m)) }
| PLUS FLOAT { let (f, m) = $2 in ([], Ppxlib.Pconst_float(f, m)) }
;
(* Identifiers and long identifiers *)
ident: UIDENT | LIDENT { $1 };
mod_ident:
| UIDENT { Some $1 }
| UNDERSCORE { None }
val_ident:
| LIDENT { $1 }
| LPAREN operator RPAREN { $2 }
;
%inline infix_operator:
| GREATER { ">" }
| INFIXOP0 { $1 }
| INFIXOP1 { $1 }
| INFIXOP2 { $1 }
| INFIXOP3 { $1 }
(* SLASHGREATER is INFIXOP3 but we needed to call it out specially *)
| SLASHGREATER { "/>" }
| INFIXOP4 { $1 }
| PLUS { "+" }
| PLUSDOT { "+." }
| MINUS { "-" }
| MINUSDOT { "-." }
| STAR { "*" }
| LESS { "<" }
| OR { "or" }
| BARBAR { "||" }
| AMPERSAND { "&" }
| AMPERAMPER { "&&" }
| COLONEQUAL { ":=" }
| PLUSEQ { "+=" }
| PERCENT { "%" }
| GREATERDOTDOTDOT { ">..." }
(* We don't need to (and don't want to) consider </> an infix operator for now
because our lexer requires that "</>" be expressed as "<\/>" because
every star and slash after the first character must be escaped.
*)
(* Also, we don't want to consider <> an infix operator because the Reason
operator swapping requires that we express that as != *)
| LESSDOTDOTGREATER { "<..>" }
| GREATER GREATER { ">>" }
operator:
| PREFIXOP { $1 }
| POSTFIXOP { $1 }
| BANG { "!" }
| infix_operator { $1 }
| LETOP { $1 }
| ANDOP { $1 }
;
%inline constr_ident:
| UIDENT { $1 }
| LBRACKET RBRACKET { "[]" }
| LPAREN RPAREN { "()" }
| COLONCOLON { "::" }
(* | LPAREN COLONCOLON RPAREN { "::" } *)
| FALSE { "false" }
| TRUE { "true" }
;
val_longident:
| val_ident { Lident $1 }
| mod_longident DOT val_ident { Ppxlib.Longident.Ldot($1, $3) }
;
constr_longident:
| mod_longident %prec below_DOT { $1 }
| LBRACKET RBRACKET { Ppxlib.Longident.Lident "[]" }
| LPAREN RPAREN { Ppxlib.Longident.Lident "()" }
| FALSE { Ppxlib.Longident.Lident "false" }
| TRUE { Ppxlib.Longident.Lident "true" }
;
label_longident:
| LIDENT { Ppxlib.Longident.Lident $1 }
| mod_longident DOT LIDENT { Ppxlib.Longident.Ldot($1, $3) }
;
type_longident: as_loc(itype_longident) { $1 };
%inline itype_longident:
| LIDENT { Ppxlib.Longident.Lident $1 }
| mod_ext_longident DOT LIDENT { Ppxlib.Longident.Ldot($1, $3) }
;
mod_longident:
| UIDENT { Ppxlib.Longident.Lident $1 }
| mod_longident DOT UIDENT { Ppxlib.Longident.Ldot($1, $3) }
;
/*
mod_less_uident_ext_longident:
imod_less_uident_ext_longident { $1 }
;
%inline imod_less_uident_ext_longident:
| LESSUIDENT { Ppxlib.Longident.Lident $1 }
| mod_ext_longident DOT UIDENT { Ppxlib.Longident.Ldot($1, $3) }
;
*/
mod_ext_longident: imod_ext_longident { $1 }
%inline imod_ext_longident:
| UIDENT { Ppxlib.Longident.Lident $1 }
| mod_ext_longident DOT UIDENT { Ppxlib.Longident.Ldot($1, $3) }
| mod_ext_apply { $1 }
;
mod_ext_apply:
imod_ext_longident
parenthesized(lseparated_nonempty_list(COMMA, mod_ext_longident))
{ if not !Clflags.applicative_functors then (
let loc = mklocation $startpos $endpos in
raise_error (Applicative_path loc) loc
);
List.fold_left ~f:(fun p1 p2 -> Ppxlib.Longident.Lapply (p1, p2)) ~init:$1 $2
}
;
mod_ext_lesslongident: imod_ext_lesslongident { $1 }
%inline imod_ext_lesslongident:
| LESSUIDENT { Ppxlib.Longident.Lident $1 }
| mod_ext_lesslongident DOT UIDENT { Ppxlib.Longident.Ldot($1, $3) }
| mod_ext_less_apply { $1 }
;
mod_ext_less_apply:
imod_ext_lesslongident
parenthesized(lseparated_nonempty_list(COMMA, mod_ext_longident))
{ if not !Clflags.applicative_functors then (
let loc = mklocation $startpos $endpos in
raise_error (Applicative_path loc) loc
);
List.fold_left ~f:(fun p1 p2 -> Ppxlib.Longident.Lapply (p1, p2)) ~init:$1 $2
}
;
mty_longident:
| ident { Lident $1 }
| mod_ext_longident DOT ident { Ppxlib.Longident.Ldot($1, $3) }
;
clty_longident:
| LIDENT { Lident $1 }
| mod_ext_longident DOT LIDENT { Ppxlib.Longident.Ldot($1, $3) }
;
class_longident:
| LIDENT { Lident $1 }
| mod_longident DOT LIDENT { Ppxlib.Longident.Ldot($1, $3) }
;
(* Toplevel directives *)
toplevel_directive:
SHARP as_loc(ident) embedded
( (* empty *) { None }
| STRING { let (s, _, _) = $1 in Some(Ppxlib.Pdir_string s) }
| INT { let (n, m) = $1 in Some(Ppxlib.Pdir_int (n, m)) }
| val_longident { Some(Ppxlib.Pdir_ident $1) }
| mod_longident { Some(Ppxlib.Pdir_ident $1) }
| FALSE { Some(Ppxlib.Pdir_bool false) }
| TRUE { Some(Ppxlib.Pdir_bool true) }
)
{
let pdir_arg = match $3 with
| None -> None
| Some pdira_desc -> Some {
Ppxlib.pdira_desc;
pdira_loc = mklocation $startpos($3) $endpos($3);
}
in
Ppxlib.Ptop_dir
{ pdir_name = $2
; pdir_arg
; pdir_loc = $2.loc
}
}
;
(* Miscellaneous *)
opt_LET_MODULE: MODULE { () } | LET MODULE { () };
%inline name_tag: BACKQUOTE ident { $2 };
%inline label: LIDENT { $1 };
rec_flag:
| (* empty *) { Nonrecursive }
| REC { Recursive }
;
nonrec_flag:
| (* empty *) { Recursive }
| NONREC { Nonrecursive }
;
direction_flag:
| TO { Upto }
| DOWNTO { Downto }
;
%inline private_flag:
| (* empty *) { Public }
| PRI { Private }
;
mutable_flag:
| (* empty *) { Immutable }
| MUTABLE { Mutable }
;
virtual_flag:
| (* empty *) { Concrete }
| VIRTUAL { Virtual }
;
mutable_or_virtual_flags:
| (* empty *) { Immutable, Concrete }
| VIRTUAL mutable_flag { $2, Virtual }
| MUTABLE virtual_flag { Mutable, $2 }
;
override_flag:
| (* empty *) { Fresh }
| BANG { Override }
;
%inline subtractive:
| MINUS { "-" }
| MINUSDOT { "-." }
;
%inline additive:
| PLUS { "+" }
| PLUSDOT { "+." }
;
single_attr_id:
| LIDENT { $1 }
| UIDENT { $1 }
| AND { "and" }
| AS { "as" }
| ASSERT { "assert" }
| BEGIN { "begin" }
| CLASS { "class" }
| CONSTRAINT { "constraint" }
| DO { "do" }
| DONE { "done" }
| DOWNTO { "downto" }
| ELSE { "else" }
| END { "end" }
| EXCEPTION { "exception" }
| EXTERNAL { "external" }
| FALSE { "false" }
| FOR { "for" }
| FUN { "fun" }
| FUNCTION { "function" }
| FUNCTOR { "functor" }
| IF { "if" }
| IN { "in" }
| INCLUDE { "include" }
| INHERIT { "inherit" }
| INITIALIZER { "initializer" }
| LAZY { "lazy" }
| LET { "let" }
| SWITCH { "switch" }
| MODULE { "module" }
| MUTABLE { "mutable" }
| NEW { "new" }
| NONREC { "nonrec" }
| OBJECT { "object" }
| OF { "of" }
| OPEN { "open" }
| OR { "or" }
| PRI { "private" }
| REC { "rec" }
| SIG { "sig" }
| STRUCT { "struct" }
| THEN { "then" }
| TO { "to" }
| TRUE { "true" }
| TRY { "try" }
| TYPE { "type" }
| VAL { "val" }
| VIRTUAL { "virtual" }
| WHEN { "when" }
| WHILE { "while" }
| WITH { "with" }
(* mod/land/lor/lxor/lsl/lsr/asr are not supported for now *)
;
attr_id:
| as_loc(single_attr_id) { $1 }
| single_attr_id DOT attr_id { mkloc ($1 ^ "." ^ $3.txt) (mklocation $symbolstartpos $endpos) }
;
attribute:
| LBRACKETAT attr_id payload RBRACKET
{
{ attr_name = $2;
attr_payload = $3;
attr_loc = mklocation $symbolstartpos $endpos
}
}
| DOCSTRING {
(* Here is where we will make another copy of doc_attr but with
* reason.doc/text instead of ocaml.doc/text and _that_ is the one that the
* printer should pay attention to, completely ignoring the ocaml.doc/text
* ones. The ocaml.doc/text ones would only be received by odoc. *)
doc_attr $1 (mklocation $symbolstartpos $endpos)
}
;
(* Inlined to avoid having to deal with buggy $symbolstartpos *)
%inline located_attributes: as_loc(attribute)+ { $1 }
(* Inlined to avoid having to deal with buggy $symbolstartpos *)
%inline item_attributes:
| { [] }
| located_attributes { List.map ~f:(fun x -> x.txt) $1 }
;
item_extension_sugar:
PERCENT attr_id { ([], $2) }
;
extension:
LBRACKETPERCENT attr_id payload RBRACKET { ($2, $3) }
| QUOTED_STRING_EXPR
{ let loc = mklocation $symbolstartpos $endpos in
mk_quotedext ~loc $1 }
;
item_extension:
LBRACKETPERCENTPERCENT attr_id payload RBRACKET { ($2, $3) }
| QUOTED_STRING_ITEM
{ let loc = mklocation $symbolstartpos $endpos in
mk_quotedext ~loc $1 }
;
payload:
| structure { PStr $1 }
| COLON signature { PSig $2 }
| COLON core_type { PTyp $2 }
| QUESTION pattern { PPat ($2, None) }
| QUESTION pattern WHEN expr { PPat ($2, Some $4) }
(* Allow parsing of [@test.call x => x]
* By putting this rule here, a reduce/reduce conflict can be avoided
* If we put the "simple_pattern_ident EQUALGREATER expr" inside the
* unattributed_expr_template, the following ambiguity pops up:
* BAR pattern option(preceded(WHEN,expr)) EQUALGREATER expr
* WHEN expr
* simple_pattern_ident EQUALGREATER expr // lookahead token appears
* val_ident .
*
* BAR pattern option(preceded(WHEN,expr)) EQUALGREATER expr // lookahead token appears
* WHEN expr // lookahead token is inherited
* simple_expr_call // lookahead token is inherited
* val_longident // lookahead token is inherited
* val_ident .
* Since where in a payload here, there's no ambiguity when putting
* the es6-style function (single arg, no parens) at this level.
*)
| simple_pattern_ident EQUALGREATER expr
{ let loc = mklocation $symbolstartpos $endpos in
let expr = Ast_helper.Exp.fun_ ~loc Nolabel None $1 $3 in
Ppxlib.PStr([mkstrexp expr []])
}
;
optional:
| { fun x -> Labelled x }
| QUESTION { fun x -> Optional x }
;
%inline mark_position_mod(X): x = X
{
let x: Ppxlib.module_expr = x in
{x with pmod_loc = {x.pmod_loc with loc_start = $symbolstartpos; loc_end = $endpos}} }
;
%inline mark_position_cty(X): x = X
{
let x : Ppxlib.class_type = x in
{x with pcty_loc = {x.pcty_loc with loc_start = $symbolstartpos; loc_end = $endpos}} }
;
%inline mark_position_ctf(X): x = X
{
let x: Ppxlib.class_type_field = x in
{x with pctf_loc = {x.pctf_loc with loc_start = $symbolstartpos; loc_end = $endpos}} }
;
%inline mark_position_exp(X): x = X
{
let x: Ppxlib.expression = x in
{x with pexp_loc = {x.pexp_loc with loc_start = $symbolstartpos; loc_end = $endpos}} }
;
%inline mark_position_typ(X): x = X
{
let x: Ppxlib.core_type = x in
{ x
with ptyp_loc =
{ x.ptyp_loc with loc_start = $symbolstartpos; loc_end = $endpos }
}
}
;
%inline mark_position_mty(X): x = X
{
let x: Ppxlib.module_type = x in
{ x
with pmty_loc =
{x.pmty_loc with loc_start = $symbolstartpos; loc_end = $endpos}
}
}
;
%inline mark_position_str(X): x = X
{
let x: Ppxlib.structure_item = x in
{ x
with pstr_loc =
{ x.pstr_loc with loc_start = $symbolstartpos; loc_end = $endpos }
}
}
;
%inline mark_position_cl(X): x = X
{
let x: Ppxlib.class_expr = x in
{x with pcl_loc = {x.pcl_loc with loc_start = $symbolstartpos; loc_end = $endpos}} }
;
%inline mark_position_cf(X): x = X
{
let x: Ppxlib.class_field = x in
{x with pcf_loc = {x.pcf_loc with loc_start = $symbolstartpos; loc_end = $endpos}} }
;
%inline mark_position_pat(X): x = X
{
let x: Ppxlib.pattern = x in
{ x
with ppat_loc =
{x.ppat_loc with loc_start = $symbolstartpos; loc_end = $endpos}} }
;
%inline as_loc(X): x = X
{ mkloc x (mklocation $symbolstartpos $endpos) }
;
either(X,Y):
| X { $1 }
| Y { $1 }
;
%inline opt_spread(X):
| DOTDOTDOT? X
{ let dotdotdot = match $1 with
| Some _ -> Some (mklocation $startpos($1) $endpos($2))
| None -> None
in
(dotdotdot, $2)
}
;
%inline lnonempty_list(X): X llist_aux(X) { $1 :: List.rev $2 };
%inline llist(X): llist_aux(X) { List.rev $1 };
llist_aux(X):
| (* empty *) { [] }
| llist_aux(X) X { $2 :: $1 }
;
%inline lseparated_list(sep, X):
| (* empty *) { [] }
| lseparated_nonempty_list(sep, X) { $1 };
%inline lseparated_nonempty_list(sep, X):
lseparated_nonempty_list_aux(sep, X) { List.rev $1 };
lseparated_nonempty_list_aux(sep, X):
| X { [$1] }
| lseparated_nonempty_list_aux(sep, X) sep X { $3 :: $1 }
;
%inline lseparated_two_or_more(sep, X):
X sep lseparated_nonempty_list(sep, X) { $1 :: $3 };
%inline parenthesized(X): delimited(LPAREN, X, RPAREN) { $1 };
(*Less than followed by one or more X, then greater than *)
%inline lessthangreaterthanized(X): delimited(LESS, X, GREATER) { $1 };
%%
================================================
FILE: src/reason-parser/reason_parser_def.ml
================================================
open Ppxlib
type labelled_parameter =
| Term of Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern
| Type of string
type let_bindings =
{ lbs_bindings : Parsetree.value_binding list
; lbs_rec : Asttypes.rec_flag
; lbs_extension : (Parsetree.attributes * string Asttypes.loc) option
; lbs_loc : Location.t
}
================================================
FILE: src/reason-parser/reason_parser_def.mli
================================================
open Ppxlib
type labelled_parameter =
| Term of Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern
| Type of string
type let_bindings =
{ lbs_bindings : Parsetree.value_binding list
; lbs_rec : Asttypes.rec_flag
; lbs_extension : (Parsetree.attributes * string Asttypes.loc) option
; lbs_loc : Location.t
}
================================================
FILE: src/reason-parser/reason_parser_explain.ml
================================================
(* See the comments in menhir_error_processor.ml *)
module Parser = Reason_parser
module Interp = Parser.MenhirInterpreter
module Raw = Reason_parser_explain_raw
let identlike_keywords =
let reverse_table =
lazy
(let table = Hashtbl.create 7 in
let flip_add k v = Hashtbl.add table v k in
Hashtbl.iter flip_add Reason_declarative_lexer.keyword_table;
table)
in
function
| Parser.SIG -> Some "sig"
| Parser.MODULE -> Some "module"
| Parser.BEGIN -> Some "begin"
| Parser.END -> Some "end"
| Parser.OBJECT -> Some "object"
| Parser.SWITCH -> Some "switch"
| Parser.TO -> Some "to"
| Parser.THEN -> Some "then"
| Parser.TYPE -> Some "type"
| token ->
(match Hashtbl.find (Lazy.force reverse_table) token with
| name -> Some name
| exception Not_found -> None)
let keyword_confused_with_ident state token =
match identlike_keywords token with
| Some name
when Raw.transitions_on_lident state || Raw.transitions_on_uident state ->
name
^ " is a reserved keyword, it cannot be used as an identifier. Try `"
^ name
^ "_` or `_"
^ name
^ "` instead"
| _ -> raise Not_found
let uppercased_instead_of_lowercased state token =
match token with
| Parser.UIDENT name when Raw.transitions_on_lident state ->
let name = String.uncapitalize_ascii name in
if Hashtbl.mem Reason_declarative_lexer.keyword_table name
then "variables and labels should be lowercased"
else
Printf.sprintf "variables and labels should be lowercased. Try `%s'" name
| _ -> raise Not_found
let semicolon_might_be_missing state _token =
(*let state = Interp.current_state_number env in*)
if Raw.transitions_on_semi state
then "syntax error, consider adding a `;' before"
else raise Not_found
let token_specific_message = function
| Parser.UNDERSCORE ->
"underscore is not a valid identifier. Use _ only in pattern matching and \
partial function application"
| _ -> raise Not_found
let unclosed_parenthesis is_opening_symbol closing_symbol check_function env =
let state = Interp.current_state_number env in
if check_function state
then
let rec find_opening_location = function
| None -> None
| Some env ->
let found =
match Interp.top env with
| Some (Interp.Element (state, _, startp, endp))
when is_opening_symbol (Interp.X (Interp.incoming_symbol state)) ->
Some (startp, endp)
| Some (Interp.Element (state, _, _, _))
when Interp.X (Interp.incoming_symbol state) = closing_symbol ->
raise Not_found
| _ -> None
in
(match found with
| Some _ -> found
| _ -> find_opening_location (Interp.pop env))
in
try find_opening_location (Some env) with Not_found -> None
else None
let check_unclosed env =
let check (message, opening_symbols, closing_symbol, check_function) =
match
unclosed_parenthesis
(List.mem ~set:opening_symbols)
closing_symbol
check_function
env
with
| None -> None
| Some (loc_start, _) ->
Some
(Format.asprintf
"Unclosed %S (opened line %d, column %d)"
message
loc_start.pos_lnum
(loc_start.pos_cnum - loc_start.pos_bol))
in
let rec check_list = function
| [] -> raise Not_found
| x :: xs ->
(match check x with None -> check_list xs | Some result -> result)
in
check_list
[ ( "("
, Interp.[ X (T T_LPAREN) ]
, Interp.X (T T_RPAREN)
, Raw.transitions_on_rparen )
; ( "{"
, Interp.[ X (T T_LBRACE); X (T T_LBRACELESS) ]
, Interp.X (T T_RBRACE)
, Raw.transitions_on_rbrace )
; ( "["
, Interp.
[ X (T T_LBRACKET)
; X (T T_LBRACKETAT)
; X (T T_LBRACKETBAR)
; X (T T_LBRACKETGREATER)
; X (T T_LBRACKETLESS)
; X (T T_LBRACKETPERCENT)
; X (T T_LBRACKETPERCENTPERCENT)
]
, Interp.X (T T_RBRACKET)
, Raw.transitions_on_rbracket )
]
let message env (token, _, _) =
let state = Interp.current_state_number env in
(* Identify a keyword used as an identifier *)
try keyword_confused_with_ident state token with
| Not_found ->
(try check_unclosed env with
| Not_found ->
(* Identify an uppercased identifier in a lowercase place *)
(try uppercased_instead_of_lowercased state token with
| Not_found ->
(try semicolon_might_be_missing state token with
| Not_found ->
(try token_specific_message token with
| Not_found ->
(* Is there a message for this specific state ? *)
(* TODO: we don't know what to say *)
"Syntax error"))))
================================================
FILE: src/reason-parser/reason_parser_explain.mli
================================================
(* See the comments in menhir_error_processor.ml *)
val message :
'a Reason_parser.MenhirInterpreter.env
-> Reason_parser.token * 'b * 'c
-> string
================================================
FILE: src/reason-parser/reason_pprint_ast.ml
================================================
(* Copyright (c) 2015-present, Facebook, Inc. * * This source code is licensed
under the MIT license found in the * LICENSE file in the root directory of
this source tree. * Forked from OCaml, which is provided under the license
below: * * Xavier Leroy, projet Cristal, INRIA Rocquencourt * * Copyright ©
1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006 Inria * *
Permission is hereby granted, free of charge, to the Licensee obtaining a *
copy of this software and associated documentation files (the "Software"), *
to deal in the Software without restriction, including without limitation *
the rights to use, copy, modify, merge, publish, distribute, sublicense *
under any license of the Licensee's choice, and/or sell copies of the *
Software, subject to the following conditions: * * 1. Redistributions of
source code must retain the above copyright notice * and the following
disclaimer. * 2. Redistributions in binary form must reproduce the above
copyright * notice, the following disclaimer in the documentation and/or
other * materials provided with the distribution. * 3. All advertising
materials mentioning features or use of the Software * must display the
following acknowledgement: This product includes all or * parts of the Caml
system developed by Inria and its contributors. * 4. Other than specified in
clause 3, neither the name of Inria nor the * names of its contributors may
be used to endorse or promote products * derived from the Software without
specific prior written permission. * * Disclaimer * * This software is
provided by Inria and contributors “as is” and any express * or implied
warranties, including, but not limited to, the implied * warranties of
merchantability and fitness for a particular purpose are * disclaimed. in no
event shall Inria or its contributors be liable for any * direct, indirect,
incidental, special, exemplary, or consequential damages * (including, but
not limited to, procurement of substitute goods or * services; loss of use,
data, or profits; or business interruption) however * caused and on any
theory of liability, whether in contract, strict * liability, or tort
(including negligence or otherwise) arising in any way * out of the use of
this software, even if advised of the possibility of such * damage. * *)
(* TODO more fine-grained precedence pretty-printing *)
module Easy_format = Reason_easy_format
open Ppxlib
open Easy_format
module Comment = Reason_comment
module Layout = Reason_layout
module WhitespaceRegion = Layout.WhitespaceRegion
module Range = Reason_location.Range
let source_map = Layout.source_map
exception NotPossible of string
let commaTrail =
Layout.SepFinal (",", Reason_syntax_util.TrailingCommaMarker.string)
let commaSep = Layout.Sep ","
type ruleInfoData =
{ reducePrecedence : precedence
; shiftPrecedence : precedence
}
and ruleCategory =
(* Printing will be parsed with very high precedence, so not much need to
worry about ensuring it will reduce correctly. In short, you can put
`FunctionApplication` content anywhere around an infix identifier without
wrapping in parens. For example `myFunc x y z` or `if x {y} else {z}` The
layout is kept in list form only to allow for elegant wrapping rules to
take into consideration the *number* of high precedence parsed items. *)
| FunctionApplication of Layout.t list
(* Care should be taken to ensure the rule that caused it to be parsed will
reduce again on the printed output - context should carefully consider
wrapping in parens according to the ruleInfoData. *)
| SpecificInfixPrecedence of ruleInfoData * resolvedRule
(* Not safe to include anywhere between infix operators without wrapping in
parens. This describes expressions like `fun x => x` which doesn't fit into
our simplistic algorithm for printing function applications separated by
infix.
It might be possible to include these in between infix, but there are
tricky rules to determining when these must be guarded by parens (it
depends highly on context that is hard to reason about). It's so nuanced
that it's easier just to always wrap them in parens. *)
| PotentiallyLowPrecedence of Layout.t
(* Simple means it is clearly one token (such as (anything) or [anything] or
identifier *)
| Simple of Layout.t
(* Represents a ruleCategory where the precedence has been resolved. * The
precedence of a ruleCategory gets resolved in `ensureExpression` or *
`ensureContainingRule`. The result is either a plain Layout.t (where * parens
probably have been applied) or an InfixTree containing the operator and * a
left & right resolvedRule. The latter indicates that the precedence has been
resolved, * but the actual formatting is deferred to a later stadium. * Think
`let x = foo |> f |> z |>`, which requires a certain formatting style when *
things break over multiple lines. *)
and resolvedRule =
| LayoutNode of Layout.t
| InfixTree of string * resolvedRule * resolvedRule
and associativity =
| Right
| Nonassoc
| Left
and precedenceEntryType =
| TokenPrecedence
| CustomPrecedence
and precedence =
| Token of string
| Custom of string
(* Describes the "fixity" of a token, and stores its *printed* representation
should it be rendered as infix/prefix (This rendering may be different than
how it is stored in the AST). *)
and tokenFixity =
(* Such as !simple_expr and ~!simple_expr. These function applications are
considered *almost* "simple" because they may be allowed anywhere a simple
expression is accepted, except for when on the left hand side of a
dot/send. *)
| AlmostSimplePrefix of string
| UnaryPlusPrefix of string
| UnaryMinusPrefix of string
| UnaryNotPrefix of string
| UnaryPostfix of string
| Infix of string
| Letop of string
| Andop of string
| Normal
(* Type which represents a resolvedRule's InfixTree flattened *)
type infixChain =
| InfixToken of string
| Layout of Layout.t
(* Helpers for dealing with extension nodes (%expr) *)
let expression_extension_sugar x =
if x.pexp_attributes != []
then None
else
match x.pexp_desc with
| Pexp_extension (name, PStr [ { pstr_desc = Pstr_eval (expr, []); _ } ])
when name.txt <> "mel.obj" ->
Some (name, expr)
| _ -> None
let expression_immediate_extension_sugar x =
match expression_extension_sugar x with
| None -> None, x
| Some (name, expr) ->
(match expr.pexp_desc with
| Pexp_for _ | Pexp_while _ | Pexp_ifthenelse _
| Pexp_function (_, _, Pfunction_cases _)
| Pexp_newtype _ | Pexp_try _ | Pexp_match _ ->
Some name, expr
| _ -> None, x)
let expression_not_immediate_extension_sugar x =
match expression_immediate_extension_sugar x with
| Some _, _ -> None
| None, _ -> expression_extension_sugar x
let add_extension_sugar keyword = function
| None -> keyword
| Some str -> keyword ^ "%" ^ str.txt
let override = function Override -> "!" | Fresh -> ""
let add_open_extension_sugar ~override:open_override extension =
let base = "open" in
match extension, open_override with
| extension, Fresh -> add_extension_sugar base extension
| None, Override -> base ^ override open_override
| Some _, Override ->
(* need to add a space between `!` and `%foo` otherwise it can't be parsed
back *)
add_extension_sugar (base ^ override open_override ^ " ") extension
let string_equal : string -> string -> bool = ( = )
let string_loc_equal : string Asttypes.loc -> string Asttypes.loc -> bool =
fun l1 l2 -> l1.txt = l2.txt
let longident_same l1 l2 =
let rec equal l1 l2 =
match l1, l2 with
| Lident l1, Lident l2 -> string_equal l1 l2
| Ldot (path1, l1), Ldot (path2, l2) ->
equal path1 path2 && string_equal l1 l2
| Lapply (l11, l12), Lapply (l21, l22) -> equal l11 l21 && equal l12 l22
| _ -> false
in
equal l1.txt l2.txt
(* A variant of List.for_all2 that returns false instead of failing on lists of
different size *)
let for_all2' pred l1 l2 = try List.for_all2 ~f:pred l1 l2 with _ -> false
(* Checks to see if two types are the same modulo the process of varification
which turns abstract types into type variables of the same name. For example,
[same_ast_modulo_varification] would consider (a => b) and ('a => 'b) to have
the same ast. This is useful in recovering syntactic sugar for explicit
polymorphic types with locally abstract types.
Does not compare attributes, or extensions intentionally.
TODO: This has one more issue: We need to compare only accepting t1's type
variables, to be considered compatible with t2's type constructors - not the
other way around. *)
let same_ast_modulo_varification_and_extensions t1 t2 =
let rec loop t1 t2 =
match t1.ptyp_desc, t2.ptyp_desc with
(* Importantly, cover the case where type constructors (of the form [a]) are
converted to type vars of the form ['a]. *)
| Ptyp_constr ({ txt = Lident s1; _ }, []), Ptyp_var s2 ->
string_equal s1 s2
(* Now cover the case where type variables (of the form ['a]) are converted
to type constructors of the form [a]. *)
| Ptyp_var s1, Ptyp_constr ({ txt = Lident s2; _ }, []) ->
string_equal s1 s2
(* Now cover the typical case *)
| Ptyp_constr (longident1, lst1), Ptyp_constr (longident2, lst2) ->
longident_same longident1 longident2 && for_all2' loop lst1 lst2
| Ptyp_any, Ptyp_any -> true
| Ptyp_var x1, Ptyp_var x2 -> string_equal x1 x2
| ( Ptyp_arrow (label1, core_type1, core_type1')
, Ptyp_arrow (label2, core_type2, core_type2') ) ->
(match label1, label2 with
| Nolabel, Nolabel -> true
| Labelled s1, Labelled s2 -> string_equal s1 s2
| Optional s1, Optional s2 -> string_equal s1 s2
| _ -> false)
&& loop core_type1 core_type2
&& loop core_type1' core_type2'
| Ptyp_tuple lst1, Ptyp_tuple lst2 -> for_all2' loop lst1 lst2
| Ptyp_object (lst1, o1), Ptyp_object (lst2, o2) ->
let tester t1 t2 =
match t1.pof_desc, t2.pof_desc with
| Otag (s1, t1), Otag (s2, t2) ->
string_equal s1.txt s2.txt && loop t1 t2
| Oinherit t1, Oinherit t2 -> loop t1 t2
| _ -> false
in
for_all2' tester lst1 lst2 && o1 = o2
| Ptyp_class (longident1, lst1), Ptyp_class (longident2, lst2) ->
longident_same longident1 longident2 && for_all2' loop lst1 lst2
| Ptyp_alias (core_type1, string1), Ptyp_alias (core_type2, string2) ->
loop core_type1 core_type2 && string_equal string1.txt string2.txt
| ( Ptyp_variant (row_field_list1, flag1, lbl_lst_option1)
, Ptyp_variant (row_field_list2, flag2, lbl_lst_option2) ) ->
for_all2' rowFieldEqual row_field_list1 row_field_list2
&& flag1 = flag2
&& lbl_lst_option1 = lbl_lst_option2
| Ptyp_poly (string_lst1, core_type1), Ptyp_poly (string_lst2, core_type2)
->
for_all2' string_loc_equal string_lst1 string_lst2
&& loop core_type1 core_type2
| Ptyp_package (longident1, lst1), Ptyp_package (longident2, lst2) ->
longident_same longident1 longident2
&& for_all2' testPackageType lst1 lst2
| Ptyp_extension (s1, _), Ptyp_extension (s2, _) ->
string_equal s1.txt s2.txt
| _ -> false
and testPackageType (lblLongIdent1, ct1) (lblLongIdent2, ct2) =
longident_same lblLongIdent1 lblLongIdent2 && loop ct1 ct2
and rowFieldEqual f1 f2 =
match f1.prf_desc, f2.prf_desc with
| Rtag (label1, flag1, lst1), Rtag (label2, flag2, lst2) ->
string_equal label1.txt label2.txt
&& flag1 = flag2
&& for_all2' loop lst1 lst2
| Rinherit t1, Rinherit t2 -> loop t1 t2
| _ -> false
in
loop t1 t2
let expandLocation pos ~expand:(startPos, endPos) =
{ pos with
loc_start =
{ pos.loc_start with
Lexing.pos_cnum = pos.loc_start.Lexing.pos_cnum + startPos
}
; loc_end =
{ pos.loc_end with
Lexing.pos_cnum = pos.loc_end.Lexing.pos_cnum + endPos
}
}
(* Computes the location of the attribute with the lowest line number * that
isn't ghost. Useful to determine the start location of an item * in the
parsetree that has attributes. * If there are no valid attributes, defaults
to the passed location. * 1| [@attr] --> notice how the "start" is determined
* 2| let f = ... by the attr on line 1, not the lnum of the `let` *)
let rec firstAttrLoc loc = function
| ({ attr_name = attrLoc; _ } : Parsetree.attribute) :: attrs ->
if
attrLoc.loc.loc_start.pos_lnum < loc.loc_start.pos_lnum
&& not attrLoc.loc.loc_ghost
then firstAttrLoc attrLoc.loc attrs
else firstAttrLoc loc attrs
| [] -> loc
let extractLocationFromValBindList expr vbs =
let rec extract loc = function
| x :: xs ->
let { pvb_expr; _ } = x in
let loc = { loc with loc_end = pvb_expr.pexp_loc.loc_end } in
extract loc xs
| [] -> loc
in
let loc =
match vbs with
| x :: xs ->
let { pvb_pat; pvb_expr; _ } = x in
let loc = { pvb_pat.ppat_loc with loc_end = pvb_expr.pexp_loc.loc_end } in
extract loc xs
| [] -> expr.pexp_loc
in
{ loc with loc_start = expr.pexp_loc.loc_start }
let extractLocValBinding { pvb_pat; pvb_expr; pvb_attributes; _ } =
let estimatedLoc = firstAttrLoc pvb_pat.ppat_loc pvb_attributes in
{ estimatedLoc with loc_end = pvb_expr.pexp_loc.loc_end }
let extractLocBindingOp { pbop_pat; pbop_exp; _ } =
let estimatedLoc = firstAttrLoc pbop_pat.ppat_loc [] in
{ estimatedLoc with loc_end = pbop_exp.pexp_loc.loc_end }
let extractLocModuleBinding { pmb_expr; pmb_attributes; _ } =
let estimatedLoc = firstAttrLoc pmb_expr.pmod_loc pmb_attributes in
{ estimatedLoc with loc_end = pmb_expr.pmod_loc.loc_end }
let extractLocModDecl { pmd_type; pmd_attributes; _ } =
let estimatedLoc = firstAttrLoc pmd_type.pmty_loc pmd_attributes in
{ estimatedLoc with loc_end = pmd_type.pmty_loc.loc_end }
let rec sequentialIfBlocks x =
match x with
| Some { pexp_desc = Pexp_ifthenelse (e1, e2, els); _ } ->
let nestedIfs, finalExpression = sequentialIfBlocks els in
(e1, e2) :: nestedIfs, finalExpression
| Some e -> [], Some e
| None -> [], None
(* TODO: IDE integration beginning with Vim: * * - Create recovering version of
parser that creates regions of "unknown" * content in between let sequence
bindings (anything between semicolons, * really). * - Use Easy_format's
"style" features to tag each known node. * - Turn those style annotations
into editor highlight commands. * - Editors have a set of keys that retrigger
the parsing/rehighlighting * process (typically newline/semi/close-brace). *
\- On every parsing/rehighlighting, this pretty printer can be used to *
determine the highlighting of recovered regions, and the editor plugin can *
relegate highlighting of malformed regions to the editor which mostly does *
so based on token patterns. * *)
(* @avoidSingleTokenWrapping
*
* +-----------------------------+
* |+------+ | Another label
* || let ( \ |
* || a | Label |
* || o | | The thing to the right of any label must be a
* || p _+ label RHS | list in order for it to wrap correctly. Lists
* || ): / v | will wrap if they need to/can. NON-lists will
* |+--+ sixteenTuple = echoTuple|( wrap (indented) even though they're no lists!
* +---/ 0,\---------------------+ To prevent a single item from wrapping, make
* 0, an unbreakable list via ensureSingleTokenSticksToLabel.
* 0
* );
* In general, the best approach for indenting
* let bindings is to keep building up labels from
* the "let", always ensuring things that you want
* to wrap will either be lists or guarded in
* [ensureSingleTokenSticksToLabel].
* If you must join several lists together (via =)
* (or colon), ensure that joining is done via
* [makeList] (which won't break), and that new
* list is always appended to the left
* hand side of the label. (So that the right hand
* side may always be the untouched list that you want
* to wrap with aligned closing).
* Always make sure rhs of the label are the
*
* Creating nested labels will preserve the original
* indent location ("let" in this
* case) as long as that nesting is
* done on the left hand side of the labels.
*
*)
(* Table 2.1. Precedence and associativity.
* Precedence from highest to lowest: From RWOC, modified to include !=
* ---------------------------------------
*
* Operator prefix Associativity
* !..., ?..., ~... Prefix
* ., .(, .[ -
* function application, constructor, assert, lazy Left associative
* -, -. Prefix
* **..., lsl, lsr, asr Right associative
* *..., /..., %..., mod, land, lor, lxor Left associative
* +..., -... Left associative
* :: Right associative
* @..., ^... Right associative
*
* != Left associative (INFIXOP0 listed first in lexer)
* =..., <..., >..., |..., &..., $... Left associative (INFIXOP0)
* =, <, > Left associative (IN SAME row as INFIXOP0 listed after)
*
* &, && Right associative
* or, || Right associative
* , -
* :=, = Right associative
* if -
* ; Right associative
*
*
* Note: It would be much better if &... and |... were in separate precedence
* groups just as & and | are. This way, we could encourage custom infix
* operators to use one of the two precedences and no one would be confused as
* to precedence (leading &, | are intuitive). Two precedence classes for the
* majority of infix operators is totally sufficient.
*
* TODO: Free up the (&) operator from pervasives so it can be reused for
* something very common such as string concatenation or list appending.
*
* let x = tail & head;
*)
(* "Almost Simple Prefix" function applications parse with the rule:
`PREFIXOP simple_expr %prec below_DOT_AND_SHARP`, which in turn is almost
considered a "simple expression" (it's acceptable anywhere a simple
expression is except in a couple of edge cases.
"Unary Prefix" function applications parse with the rule:
`MINUS epxr %prec prec_unary_minus`, which in turn is considered an
"expression" (not simple). All unary operators are mapped into an identifier
beginning with "~".
TODO: Migrate all "almost simple prefix" to "unsary prefix". When `!` becomes
"not", then it will make more sense that !myFunc (arg) is parsed as !(myFunc
arg) instead of (!myFunc) arg. *)
let almost_simple_prefix_symbols = [ '!'; '?'; '~' ]
(* Subset of prefix symbols that have special "unary precedence" *)
let unary_minus_prefix_symbols = [ "~-"; "~-." ]
let unary_plus_prefix_symbols = [ "~+"; "~+." ]
let infix_symbols =
[ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; '*'; '/'; '$'; '%'; '\\'; '#' ]
(* this should match "kwdopchar" from reason_declarative_lexer.mll *)
let special_infix_strings =
[ "asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; ":="; "!="; "!==" ]
let updateToken = "="
let sharpOpEqualToken = "#="
let pipeFirstToken = "->"
let requireIndentFor = [ updateToken; ":=" ]
let namedArgSym = "~"
let requireNoSpaceFor tok =
tok = pipeFirstToken || (tok.[0] = '#' && tok <> "#=")
let funToken = "fun"
let getPrintableUnaryIdent s =
if
List.mem s ~set:unary_minus_prefix_symbols
|| List.mem s ~set:unary_plus_prefix_symbols
then String.sub s ~pos:1 ~len:(String.length s - 1)
else s
(* determines if the string is an infix string. checks backwards, first allowing
a renaming postfix ("_102") which may have resulted from Pexp -> Texp -> Pexp
translation, then checking if all the characters in the beginning of the
string are valid infix characters. *)
let printedStringAndFixity = function
| s when List.mem s ~set:special_infix_strings -> Infix s
| "^" -> UnaryPostfix "^"
| s when List.mem s.[0] ~set:infix_symbols -> Infix s
(* Correctness under assumption that unary operators are stored in AST with
leading "~" *)
| s
when List.mem s.[0] ~set:almost_simple_prefix_symbols
&& (not (List.mem s ~set:special_infix_strings))
&& not (s = "?") ->
if
(* What *kind* of prefix fixity? *)
List.mem s ~set:unary_plus_prefix_symbols
then UnaryPlusPrefix (getPrintableUnaryIdent s)
else if List.mem s ~set:unary_minus_prefix_symbols
then UnaryMinusPrefix (getPrintableUnaryIdent s)
else if s = "!"
then UnaryNotPrefix s
else AlmostSimplePrefix s
| s when Reason_syntax_util.is_letop s -> Letop s
| s when Reason_syntax_util.is_andop s -> Andop s
| _ -> Normal
(* Also, this doesn't account for != and !== being infixop!!! *)
let isSimplePrefixToken s =
match printedStringAndFixity s with
| AlmostSimplePrefix _ | UnaryPostfix "^" -> true
| _ -> false
(* Convenient bank of information that represents the parser's precedence
rankings. Each instance describes a precedence table entry. The function
tests either a token string encountered by the parser, or (in the case of
`CustomPrecedence`) the string name of a custom rule precedence declared
using %prec *)
let rules =
[ [ (TokenPrecedence, fun s -> Left, s = pipeFirstToken)
; ( TokenPrecedence
, fun s -> Left, s.[0] = '#' && s <> sharpOpEqualToken && s <> "#" )
; (TokenPrecedence, fun s -> Left, s = ".")
; (CustomPrecedence, fun s -> Left, s = "prec_lbracket")
]
; [ (CustomPrecedence, fun s -> Nonassoc, s = "prec_functionAppl") ]
; [ (TokenPrecedence, fun s -> Right, isSimplePrefixToken s) ]
; [ (TokenPrecedence, fun s -> Left, s = sharpOpEqualToken) ]
; [ (CustomPrecedence, fun s -> Nonassoc, s = "prec_unary") ]
; (* Note the special case for "*\*", BARBAR, and LESSMINUS, AMPERSAND(s) *)
[ (TokenPrecedence, fun s -> Right, s = "**")
; ( TokenPrecedence
, fun s ->
( Right
, String.length s > 1 && s.[0] == '*' && s.[1] == '\\' && s.[2] == '*'
) )
; (TokenPrecedence, fun s -> Right, s = "lsl")
; (TokenPrecedence, fun s -> Right, s = "lsr")
; (TokenPrecedence, fun s -> Right, s = "asr")
]
; [ ( TokenPrecedence
, fun s -> Left, s.[0] == '*' && (String.length s == 1 || s != "*\\*") )
; (TokenPrecedence, fun s -> Left, s.[0] == '/')
; (TokenPrecedence, fun s -> Left, s.[0] == '%')
; (TokenPrecedence, fun s -> Left, s = "mod")
; (TokenPrecedence, fun s -> Left, s = "land")
; (TokenPrecedence, fun s -> Left, s = "lor")
; (TokenPrecedence, fun s -> Left, s = "lxor")
]
; [ (* Even though these use the same *tokens* as unary plus/minus at parse
time, when unparsing infix -/+, the CustomPrecedence rule would be
incorrect to use, and instead we need a rule that models what infix
parsing would use - just the regular token precedence without a custom
precedence. *)
( TokenPrecedence
, fun s ->
( Left
, if String.length s > 1 && s.[0] == '+' && s.[1] == '+'
then
(* Explicitly call this out as false because the other ++ case
below should have higher *lexing* priority. ++operator_chars*
is considered an entirely different token than
+(non_plus_operator_chars)* *)
false
else s.[0] == '+' ) )
; (TokenPrecedence, fun s -> Left, s.[0] == '-' && s <> pipeFirstToken)
; (TokenPrecedence, fun s -> Left, s = "!")
]
; [ (TokenPrecedence, fun s -> Right, s = "::") ]
; [ (TokenPrecedence, fun s -> Right, s.[0] == '@')
; (TokenPrecedence, fun s -> Right, s.[0] == '^')
; ( TokenPrecedence
, fun s -> Right, String.length s > 1 && s.[0] == '+' && s.[1] == '+' )
]
; [ ( TokenPrecedence
, fun s -> Left, s.[0] == '=' && (not (s = "=")) && not (s = "=>") )
; (TokenPrecedence, fun s -> Left, s.[0] == '<' && not (s = "<"))
; (TokenPrecedence, fun s -> Left, s.[0] == '>' && not (s = ">"))
; (TokenPrecedence, fun s -> Left, s = "!=")
; (* Not preset in the RWO table! *)
(TokenPrecedence, fun s -> Left, s = "!==")
; (* Not preset in the RWO table! *)
(TokenPrecedence, fun s -> Left, s = "==")
; (TokenPrecedence, fun s -> Left, s = "===")
; (TokenPrecedence, fun s -> Left, s = "<")
; (TokenPrecedence, fun s -> Left, s = ">")
; (TokenPrecedence, fun s -> Left, s.[0] == '|' && not (s = "||"))
; ( TokenPrecedence
, fun s -> Left, s.[0] == '&' && (not (s = "&")) && not (s = "&&") )
; (TokenPrecedence, fun s -> Left, s.[0] == '$')
]
; [ (CustomPrecedence, fun s -> Left, s = funToken) ]
; [ (TokenPrecedence, fun s -> Right, s = "&")
; (TokenPrecedence, fun s -> Right, s = "&&")
]
; [ (TokenPrecedence, fun s -> Right, s = "or")
; (TokenPrecedence, fun s -> Right, s = "||")
]
; [ (* The Left shouldn't ever matter in practice. Should never get in a
situation with two consecutive infix ? - the colon saves us. *)
(TokenPrecedence, fun s -> Left, s = "?")
]
; [ (TokenPrecedence, fun s -> Right, s = ":=") ]
; [ (TokenPrecedence, fun s -> Right, s = updateToken) ]
; (* It's important to account for ternary ":" being lower precedence than
"?" *)
[ (TokenPrecedence, fun s -> Right, s = ":") ]
; [ (TokenPrecedence, fun s -> Nonassoc, s = "=>") ]
]
(* remove all prefixing backslashes, e.g. \=== becomes === *)
let without_prefixed_backslashes str =
if str = ""
then str
else if String.get str 0 = '\\'
then String.sub str ~pos:1 ~len:(String.length str - 1)
else str
let indexOfFirstMatch ~prec lst =
let rec aux n = function
| [] -> None
| [] :: tl -> aux (n + 1) tl
| ((kind, tester) :: hdTl) :: tl ->
(match prec, kind with
| Token str, TokenPrecedence | Custom str, CustomPrecedence ->
let associativity, foundMatch = tester str in
if foundMatch then Some (associativity, n) else aux n (hdTl :: tl)
| _ -> aux n (hdTl :: tl))
in
aux 0 lst
(* Assuming it's an infix function application. *)
let precedenceInfo ~prec =
(* Removes prefixed backslashes in order to do proper conversion *)
let prec =
match prec with
| Token str -> Token (without_prefixed_backslashes str)
| Custom _ -> prec
in
indexOfFirstMatch ~prec rules
let isLeftAssociative ~prec =
match precedenceInfo ~prec with
| None -> false
| Some (Left, _) -> true
| Some (Right, _) -> false
| Some (Nonassoc, _) -> false
let isRightAssociative ~prec =
match precedenceInfo ~prec with
| None -> false
| Some (Right, _) -> true
| Some (Left, _) -> false
| Some (Nonassoc, _) -> false
let higherPrecedenceThan c1 c2 =
match precedenceInfo ~prec:c1, precedenceInfo ~prec:c2 with
| _, None | None, _ ->
let str1, str2 =
match c1, c2 with
| Token s1, Token s2 -> "Token " ^ s1, "Token " ^ s2
| Token s1, Custom s2 -> "Token " ^ s1, "Custom " ^ s2
| Custom s1, Token s2 -> "Custom " ^ s1, "Token " ^ s2
| Custom s1, Custom s2 -> "Custom " ^ s1, "Custom " ^ s2
in
raise
(NotPossible
("Cannot determine precedence of two checks " ^ str1 ^ " vs. " ^ str2))
| Some (_, p1), Some (_, p2) -> p1 < p2
let printedStringAndFixityExpr = function
| { pexp_desc = Pexp_ident { txt = Lident l; _ }; _ } ->
printedStringAndFixity l
| _ -> Normal
(* which identifiers are in fact operators needing parentheses *)
let needs_parens txt =
match printedStringAndFixity txt with
| Infix _ -> true
| UnaryPostfix _ -> true
| UnaryPlusPrefix _ -> true
| UnaryMinusPrefix _ -> true
| UnaryNotPrefix _ -> true
| AlmostSimplePrefix _ -> true
| Letop _ -> true
| Andop _ -> true
| Normal -> false
(* some infixes need spaces around parens to avoid clashes with comment syntax.
This isn't needed for comment syntax /* */ *)
let needs_spaces txt = txt.[0] = '*' || txt.[String.length txt - 1] = '*'
let rec orList = function
(* only consider ((A|B)|C)*)
| { ppat_desc = Ppat_or (p1, p2); _ } -> orList p1 @ orList p2
| x -> [ x ]
(* variance encoding: need to sync up with the [parser.mly] *)
let type_variance = function
| NoVariance -> ""
| Covariant -> "+"
| Contravariant -> "-"
let moduleIdent ident = match ident.txt with None -> "_" | Some name -> name
type construct =
[ `cons of expression list
| `list of expression list
| `nil
| `normal
| `simple of Longident.t
| `tuple
| `btrue
| `bfalse
]
let view_expr x =
match x.pexp_desc with
| Pexp_construct ({ txt = Lident "()"; _ }, _) -> `tuple
| Pexp_construct ({ txt = Lident "true"; _ }, _) -> `btrue
| Pexp_construct ({ txt = Lident "false"; _ }, _) -> `bfalse
| Pexp_construct ({ txt = Lident "[]"; _ }, _) -> `nil
| Pexp_construct ({ txt = Lident "::"; _ }, Some _) ->
let rec loop exp acc =
match exp with
| { pexp_desc = Pexp_construct ({ txt = Lident "[]"; _ }, _); _ } ->
List.rev acc, true
| { pexp_desc =
Pexp_construct
( { txt = Lident "::"; _ }
, Some { pexp_desc = Pexp_tuple [ e1; e2 ]; _ } )
; _
} ->
loop e2 (e1 :: acc)
| e -> List.rev (e :: acc), false
in
let ls, b = loop x [] in
if b then `list ls else `cons ls
| Pexp_construct (x, None) -> `simple x.txt
| _ -> `normal
let is_simple_list_expr x =
match view_expr x with `list _ | `cons _ -> true | _ -> false
let is_simple_construct : construct -> bool = function
| `nil | `tuple | `list _ | `simple _ | `btrue | `bfalse | `cons _ -> true
| `normal -> false
let uncurriedTable = Hashtbl.create 42
(* Determines if a list of expressions contains a single unit construct * e.g.
used to check: MyConstructor() -> exprList == [()] * useful to determine if
MyConstructor(()) should be printed as MyConstructor() * *)
let is_single_unit_construct exprList =
match exprList with
| x :: [] ->
let view = view_expr x in
(match view with `tuple -> true | _ -> false)
| _ -> false
let detectTernary l =
match l with
| [ { pc_lhs =
{ ppat_desc = Ppat_construct ({ txt = Lident "true"; _ }, _); _ }
; pc_guard = None
; pc_rhs = ifTrue
}
; { pc_lhs =
{ ppat_desc = Ppat_construct ({ txt = Lident "false"; _ }, _); _ }
; pc_guard = None
; pc_rhs = ifFalse
}
] ->
Some (ifTrue, ifFalse)
| _ -> None
type funcApplicationLabelStyle =
(* No attaching to the label, but if the entire application fits on one line,
the entire application will appear next to the label as you 'd expect. *)
| NeverWrapFinalItem
(* Attach the first term if there are exactly two terms involved in the
application.
let x = firstTerm (secondTerm_1 secondTerm_2) thirdTerm;
Ideally, we'd be able to attach all but the last argument into the label
any time all but the last term will fit - and *not* when (attaching all but
the last term isn't enough to prevent a wrap) - But there's no way to tell
ahead of time if it would prevent a wrap.
However, the number two is somewhat convenient. This models the indentation
that you'd prefer in non-curried syntax languages like JavaScript, where
application only ever has two terms. *)
| WrapFinalListyItemIfFewerThan of int
type formatSettings =
{ space : int
; (* For curried arguments in function *definitions* only: Number of [space]s
to offset beyond the [let] keyword. Default 1. *)
listsRecordsIndent : int
; indentWrappedPatternArgs : int
; (* Amount to indent in label-like constructs such as wrapped function
applications, etc - or even record fields. This is not the same concept
as an indented curried argument list. *)
indentAfterLabels : int
; (* Amount to indent after the opening brace of switch/try.
* Here's an example of what it would look like w/ [trySwitchIndent = 2]:
* Sticks the expression to the last item in a sequence in several [X | Y | Z
* => expr], and forces X, Y, Z to be split onto several lines. (Otherwise,
* sticking to Z would result in hanging expressions). TODO: In the first case,
* it's clear that we want patterns to have an "extra" indentation with matching
* in a "match". Create extra config param to pass to [self#pattern] for extra
* indentation in this one case.
*
* switch x {
* | TwoCombos
* (HeresTwoConstructorArguments x y)
* (HeresTwoConstructorArguments a b) =>
* ((a + b) + x) + y;
* | Short
* | AlsoHasARecord a b {x, y} => (
* retOne,
* retTwo
* )
* | AlsoHasARecord a b {x, y} =>
* callMyFunction
* withArg
* withArg
* withArg
* withArg;
* }
*)
trySwitchIndent : int
; (* In the case of two term function application (when flattened), the first
* term should become part of the label, and the second term should be able to wrap
* This doesn't effect n != 2.
*
* [true]
* let x = reallyShort allFitsOnOneLine;
* let x = someFunction {
* reallyLongObject: true,
* thatWouldntFitOnThe: true,
* firstLine: true
* };
*
* [false]
* let x = reallyShort allFitsOnOneLine;
* let x =
* someFunction
* {
* reallyLongObject: true,
* thatWouldntFitOnThe: true,
* firstLine: true
* };
*)
funcApplicationLabelStyle : funcApplicationLabelStyle
; funcCurriedPatternStyle : funcApplicationLabelStyle
; width : int
; assumeExplicitArity : bool
; constructorLists : string list
}
let defaultSettings =
{ space = 1
; listsRecordsIndent = 2
; indentWrappedPatternArgs = 2
; indentAfterLabels = 2
; trySwitchIndent = 0
; funcApplicationLabelStyle = WrapFinalListyItemIfFewerThan 3
; (* WrapFinalListyItemIfFewerThan is currently a bad idea for curried
* arguments: It looks great in some cases:
*
* let myFun (a:int) :(
* int,
* string
* ) => (a, "this is a");
*
* But horrible in others:
*
* let myFun
* {
* myField,
* yourField
* } :someReturnType => myField + yourField;
*
* let myFun
* { // Curried arg wraps
* myField,
* yourField
* } : ( // But the last is "listy" so it docks
* int, // To the [let].
* int,
* int
* ) => myField + yourField;
*
* We probably want some special listy label docking/wrapping mode for
* curried function bindings.
*
*)
funcCurriedPatternStyle = NeverWrapFinalItem
; width = 80
; assumeExplicitArity = false
; constructorLists = []
}
let configuredSettings = ref defaultSettings
let configure ~width ~assumeExplicitArity ~constructorLists =
configuredSettings :=
{ defaultSettings with width; assumeExplicitArity; constructorLists }
let createFormatter () =
let module Formatter = struct
let settings = !configuredSettings
(* How do we make
* this a label?
*
* /---------------------\
* let myVal = (oneThing, {
* field: [],
* anotherField: blah
* });
*
* But in this case, this wider region a label?
* /------------------------------------------------------\
* let myVal = callSomeFunc (oneThing, {field: [], anotherField: blah}, {
* boo: 'hi'
* });
*
* This is difficult. You must form a label from the preorder traversal of every
* node - except the last encountered in the traversal. An easier heuristic is:
*
* - The last argument to a functor application is expanded.
*
* React.CreateClass SomeThing {
* let render {props} => {
* };
* }
*
* - The last argument to a function application is expanded on the same line.
* - Only if it's not curried with another invocation.
* -- Optionally: "only if everything else is an atom"
* -- Optionally: "only if there are no other args"
*
* React.createClass someThing {
* render: fn x => y,
* }
*
* !!! NOT THIS
* React.createClass someThing {
* render: fn x => y,
* }
* somethingElse
*)
let isArityClear attrs =
!configuredSettings.assumeExplicitArity
|| List.exists
~f:(function
| { attr_name = { txt = "explicit_arity"; _ }; _ } -> true
| _ -> false)
attrs
let default_indent_body = settings.listsRecordsIndent * settings.space
let makeList
?listConfigIfCommentsInterleaved
?listConfigIfEolCommentsInterleaved
?(break = Layout.Never)
?(wrap = "", "")
?(inline = true, false)
?(sep = Layout.NoSep)
?(indent = default_indent_body)
?(sepLeft = true)
?(preSpace = false)
?(postSpace = false)
?(pad = false, false)
lst
=
let config =
{ Layout.listConfigIfCommentsInterleaved
; listConfigIfEolCommentsInterleaved
; break = (if lst = [] then Layout.IfNeed else break)
; wrap
; inline
; sep
; indent
; sepLeft
; preSpace
; postSpace
; pad
}
in
Layout.Sequence (config, lst)
let makeAppList = function
| [ hd ] -> hd
| l -> makeList ~inline:(true, true) ~postSpace:true ~break:IfNeed l
let makeTup ?(wrap = "", "") ?(trailComma = true) ?(uncurried = false) l =
let lwrap, rwrap = wrap in
let lparen = lwrap ^ if uncurried then "(. " else "(" in
makeList
~wrap:(lparen, ")" ^ rwrap)
~sep:(if trailComma then commaTrail else commaSep)
~postSpace:true
~break:IfNeed
l
let ensureSingleTokenSticksToLabel x =
let listConfigIfCommentsInterleaved cfg =
let inline = true, true
and postSpace = true
and indent = 0 in
{ cfg with Layout.break = Always_rec; postSpace; indent; inline }
in
makeList ~listConfigIfCommentsInterleaved [ x ]
let unbreakLabelFormatter formatter =
let newFormatter labelTerm term =
match formatter labelTerm term with
| Easy_format.Label ((labelTerm, settings), term) ->
Easy_format.Label
((labelTerm, { settings with label_break = `Never }), term)
| _ -> failwith "not a label"
in
newFormatter
let inlineLabel labelTerm term =
let settings =
{ label_break = `Never
; space_after_label = true
; indent_after_label = 0
; label_style = Some "inlineLabel"
}
in
Easy_format.Label ((labelTerm, settings), term)
(* Just for debugging: Set debugWithHtml = true *)
let debugWithHtml = ref false
let html_escape_string s =
let buf = Buffer.create (2 * String.length s) in
for i = 0 to String.length s - 1 do
match s.[i] with
| '&' -> Buffer.add_string buf "&"
| '<' -> Buffer.add_string buf "<"
| '>' -> Buffer.add_string buf ">"
| c -> Buffer.add_char buf c
done;
Buffer.contents buf
let html_escape = `Escape_string html_escape_string
let html_style =
[ "atom", { Easy_format.tag_open = "<a>"; tag_close = "</a>" }
; "body", { tag_open = "<lb>"; tag_close = "</lb>" }
; "list", { tag_open = "<l>"; tag_close = "</l>" }
; "op", { tag_open = "<op>"; tag_close = "</op>" }
; "cl", { tag_open = "<cl>"; tag_close = "</cl>" }
; "sep", { tag_open = "<sep>"; tag_close = "</sep>" }
; "label", { tag_open = "<la>"; tag_close = "</la>" }
]
let easyLabel
?(break = `Auto)
?(space = false)
?(indent = settings.indentAfterLabels)
labelTerm
term
=
let settings =
{ label_break = break
; space_after_label = space
; indent_after_label = indent
; label_style = Some "label"
}
in
Easy_format.Label ((labelTerm, settings), term)
let label ?break ?space ?indent (labelTerm : Layout.t) (term : Layout.t) =
Layout.Label (easyLabel ?break ?indent ?space, labelTerm, term)
let atom ?loc str =
let style = { Easy_format.atom_style = Some "atomClss" } in
source_map ?loc (Layout.Easy (Easy_format.Atom (str, style)))
(** Take x,y,z and n and generate [x, y, z, ...n] *)
let makeES6List ?wrap:(lwrap, rwrap = "", "") lst last =
makeList
~wrap:(lwrap ^ "[", "]" ^ rwrap)
~break:IfNeed
~postSpace:true
~sep:commaTrail
(lst @ [ makeList [ atom "..."; last ] ])
let makeNonIndentedBreakingList lst =
(* No align closing: So that semis stick to the ends of every break *)
makeList ~break:Always_rec ~indent:0 ~inline:(true, true) lst
(* Like a <span> could place with other breakableInline lists without
upsetting final semicolons *)
let makeSpacedBreakableInlineList lst =
makeList ~break:IfNeed ~inline:(true, true) ~postSpace:true lst
let makeCommaBreakableListSurround opn cls lst =
makeList ~break:IfNeed ~postSpace:true ~sep:(Sep ",") ~wrap:(opn, cls) lst
(* TODO: Allow configuration of spacing around colon symbol *)
let formatPrecedence ?(inline = false) ?(wrap = "(", ")") ?loc formattedTerm
=
source_map
?loc
(makeList ~inline:(true, inline) ~wrap ~break:IfNeed [ formattedTerm ])
let wrap fn term =
ignore (Format.flush_str_formatter ());
fn Format.str_formatter term;
atom (Format.flush_str_formatter ())
let quoted_ext ?(pct = "%") extension i delim =
wrap
(fun ppf () ->
Format.fprintf
ppf
"{%s%s%s%s|%s|%s}"
pct
extension.txt
(if delim != "" then " " else "")
delim
i
delim)
()
(* Don't use `trim` since it kills line return too? *)
let rec beginsWithStar_ line length idx =
if idx = length
then false
else
match String.get line idx with
| '*' -> true
| '\t' | ' ' -> beginsWithStar_ line length (idx + 1)
| _ -> false
let beginsWithStar line = beginsWithStar_ line (String.length line) 0
let rec numLeadingSpace_ line length idx accum =
if idx = length
then accum
else
match String.get line idx with
| '\t' | ' ' -> numLeadingSpace_ line length (idx + 1) (accum + 1)
| _ -> accum
let numLeadingSpace line = numLeadingSpace_ line (String.length line) 0 0
(* Computes the smallest leading spaces for non-empty lines *)
let smallestLeadingSpaces strs =
let rec smallestLeadingSpaces curMin strs =
match strs with
| [] -> curMin
| "" :: tl -> smallestLeadingSpaces curMin tl
| hd :: tl ->
let leadingSpace = numLeadingSpace hd in
let nextMin = min curMin leadingSpace in
smallestLeadingSpaces nextMin tl
in
smallestLeadingSpaces 99999 strs
let rec isSequencey = function
| Layout.SourceMap (_, sub) -> isSequencey sub
| Layout.Sequence _ -> true
| Layout.Label (_, _, _) -> false
| Layout.Easy (Easy_format.List _) -> true
| Layout.Easy _ -> false
| Layout.Whitespace (_, sub) -> isSequencey sub
let inline ?(preSpace = false) ?(postSpace = false) labelTerm term =
makeList
[ labelTerm; term ]
~inline:(true, true)
~postSpace
~preSpace
~indent:0
~break:Layout.Never
let breakline labelTerm term =
makeList
[ labelTerm; term ]
~inline:(true, true)
~indent:0
~break:Always_rec
let insertBlankLines n term =
if n = 0
then term
else
makeList
~inline:(true, true)
~indent:0
~break:Always_rec
(Array.to_list (Array.make n (atom "")) @ [ term ])
let string_after s n = String.sub s ~pos:n ~len:(String.length s - n)
(* This is a special-purpose functions only used by `formatComment_`. Notice
we skip a char below during usage because we know the comment starts with
`/*` *)
let rec lineZeroMeaningfulContent_ line length idx accum =
if idx = length
then None
else
let ch = String.get line idx in
if ch = '\t' || ch = ' ' || ch = '*'
then lineZeroMeaningfulContent_ line length (idx + 1) (accum + 1)
else Some accum
let lineZeroMeaningfulContent line =
lineZeroMeaningfulContent_ line (String.length line) 1 0
let formatComment_ txt =
let commLines =
Reason_syntax_util.split_by
~keep_empty:true
(fun x -> x = '\n')
(Comment.wrap txt)
in
match commLines with
| [] -> atom ""
| [ hd ] -> atom hd
| zero :: one :: tl ->
let attemptRemoveCount = smallestLeadingSpaces (one :: tl) in
let leftPad =
if beginsWithStar one
then 1
else
match lineZeroMeaningfulContent zero with
| None -> 1
| Some num -> num + 1
in
let padNonOpeningLine s =
let numLeadingSpaceForThisLine = numLeadingSpace s in
if String.length s == 0
then ""
else
String.make leftPad ' '
^ string_after s (min attemptRemoveCount numLeadingSpaceForThisLine)
in
let lines = zero :: List.map ~f:padNonOpeningLine (one :: tl) in
makeList
~inline:(true, true)
~indent:0
~break:Always_rec
(List.map ~f:atom lines)
let formatComment comment =
source_map ~loc:(Comment.location comment) (formatComment_ comment)
let[@tail_mod_cons] rec append ?(space = false) txt = function
| Layout.SourceMap (loc, sub) ->
Layout.SourceMap (loc, append ~space txt sub)
| Sequence (config, l) when snd config.wrap <> "" ->
let sep = if space then " " else "" in
Sequence
( { config with wrap = fst config.wrap, snd config.wrap ^ sep ^ txt }
, l )
| Sequence (config, []) -> Sequence (config, [ atom txt ])
| Sequence (({ sep = NoSep; _ } as config), l)
| Sequence (({ sep = Sep ""; _ } as config), l) ->
let sub = appendSub txt ~space l in
Sequence (config, sub)
| Label (formatter, left, right) ->
Label (formatter, left, append ~space txt right)
| Whitespace (info, sub) -> Whitespace (info, append ~space txt sub)
| layout -> (inline [@tailcall false]) ~postSpace:space layout (atom txt)
and[@tail_mod_cons] appendSub txt ~space layouts =
match layouts with
| [] -> []
| [ layout ] -> [ append ~space txt layout ]
| layout :: xs -> layout :: appendSub txt ~space xs
let appendSep spaceBeforeSep sep layout =
append (if spaceBeforeSep then " " ^ sep else sep) layout
let rec flattenCommentAndSep ?(spaceBeforeSep = false) ?sepStr = function
| Layout.SourceMap (loc, sub) ->
Layout.SourceMap (loc, flattenCommentAndSep ~spaceBeforeSep ?sepStr sub)
| Layout.Whitespace (info, sub) ->
Layout.Whitespace
(info, flattenCommentAndSep ~spaceBeforeSep ?sepStr sub)
| layout ->
(match sepStr with
| None -> layout
| Some sep -> appendSep spaceBeforeSep sep layout)
let rec preOrderWalk f layout =
match f layout with
| Layout.Sequence (listConfig, sublayouts) ->
let newSublayouts = List.map ~f:(preOrderWalk f) sublayouts in
Layout.Sequence (listConfig, newSublayouts)
| Layout.Label (formatter, left, right) ->
let newLeftLayout = preOrderWalk f left in
let newRightLayout = preOrderWalk f right in
Layout.Label (formatter, newLeftLayout, newRightLayout)
| Layout.SourceMap (loc, sub) -> Layout.SourceMap (loc, preOrderWalk f sub)
| Layout.Easy _ as layout -> layout
| Layout.Whitespace (info, sub) ->
Layout.Whitespace (info, preOrderWalk f sub)
(** Recursively unbreaks a layout to make sure they stay within the same
line *)
let unbreaklayout =
preOrderWalk (function
| Layout.Sequence (listConfig, sublayouts) ->
Layout.Sequence ({ listConfig with break = Layout.Never }, sublayouts)
| Layout.Label (formatter, left, right) ->
Layout.Label (unbreakLabelFormatter formatter, left, right)
| layout -> layout)
(** [consolidateSeparator layout] walks the [layout], extract separators out
of each * list and insert them into PrintTree as separated items *)
let consolidateSeparator l =
preOrderWalk
(function
| Sequence (listConfig, sublayouts)
when listConfig.sep != NoSep && listConfig.sepLeft ->
(* TODO: Support !sepLeft, and this should apply to the *first*
separator if !sepLeft. *)
let[@tail_mod_cons] rec mapSublayout layouts =
match listConfig.sep, layouts with
| NoSep, _ ->
raise
(NotPossible
"We already covered this case. This shouldn't happen.")
| Sep _, [ layout ] -> [ layout ]
| (SepFinal (sepStr, _) | Sep sepStr), layout :: l2 :: xs ->
flattenCommentAndSep
~spaceBeforeSep:listConfig.preSpace
~sepStr
layout
:: mapSublayout (l2 :: xs)
| SepFinal (_, finalSepStr), [ layout ] ->
[ flattenCommentAndSep
~spaceBeforeSep:listConfig.preSpace
~sepStr:finalSepStr
layout
]
| _, [] -> []
in
let layoutsWithSepAndComment = mapSublayout sublayouts in
let sep = Layout.NoSep in
let preSpace = false in
Sequence
({ listConfig with sep; preSpace }, layoutsWithSepAndComment)
| layout -> layout)
l
(** [insertLinesAboveItems layout] walks the [layout] and insert empty lines
*)
let insertLinesAboveItems items =
preOrderWalk
(function
| Whitespace (region, sub) ->
insertBlankLines (WhitespaceRegion.newlines region) sub
| layout -> layout)
items
let insertCommentIntoWhitespaceRegion comment region subLayout =
let cl = Comment.location comment in
let range = WhitespaceRegion.range region in
(* append the comment to the list of inserted comments in the whitespace
region *)
let nextRegion = WhitespaceRegion.addComment region comment in
let formattedComment = formatComment comment in
match WhitespaceRegion.comments region with
(* the comment inserted into the whitespace region is the first in the
region *)
| [] ->
(* 1| let a = 1; * 2| * 3| /* comment at end of whitespace region */ *
4| let b = 2; *)
if range.lnum_end = cl.loc_end.pos_lnum
then
let subLayout = breakline formattedComment subLayout in
Layout.Whitespace (nextRegion, subLayout)
(* 1| let a = 1; * 2| /* comment at start of whitespace region */ * 3|
* 4| let b = 2;
*)
else if range.lnum_start = cl.loc_start.pos_lnum
then
let subLayout =
breakline formattedComment (insertBlankLines 1 subLayout)
in
let nextRegion = WhitespaceRegion.modifyNewlines nextRegion 0 in
Whitespace (nextRegion, subLayout)
(* 1| let a = 1; * 2| * 3| /* comment floats in whitespace region */ *
4| * 5| let b = 2; *)
else
let subLayout =
breakline formattedComment (insertBlankLines 1 subLayout)
in
Whitespace (nextRegion, subLayout)
(* The whitespace region contains already inserted comments *)
| prevComment :: _cs ->
let pcl = Comment.location prevComment in
(* check if the comment is attached to the start of the region *)
let attachedToStartRegion = cl.loc_start.pos_lnum = range.lnum_start in
let nextRegion =
(* 1| let a = 1; * 2| /* comment sits on the beginning of the region
*/ * 3| /* previous comment */ * 4| * 5| let b = 2;
*)
if attachedToStartRegion
then
(* we don't want a newline between `let a = 1` and the `comment sits
* on the beginning of the region` comment*)
WhitespaceRegion.modifyNewlines nextRegion 0
(* 1| let a = 1; * 2| * 3| /* comment isn't located at the beginnin
of a region*/ * 4| /* previous comment */ * 5| * 6| let b = 2; *)
else nextRegion
in
(* 1| let a = 1; * 2| /* comment */ * 3| --> whitespace between * 4| /*
previous comment */ * 5| let b = 1; *)
if Reason_location.hasSpaceBetween pcl cl
then
(* pcl.loc_start.pos_lnum - cl.loc_end.pos_lnum > 1 then *)
let subLayout =
breakline formattedComment (insertBlankLines 1 subLayout)
in
let withComment = Layout.Whitespace (nextRegion, subLayout) in
withComment
(* 1| let a = 1; * 2| * 3| /* comment */ | no whitespace between
`comment` * 4| /* previous comment */ | and `previous comment` * 5|
let b = 1; *)
else
let subLayout = breakline formattedComment subLayout in
let withComment = Layout.Whitespace (nextRegion, subLayout) in
withComment
(** * prependSingleLineComment inserts a single line comment right above
layout *)
let rec prependSingleLineComment comment layout =
match layout with
| Layout.SourceMap (loc, sub) ->
Layout.SourceMap (loc, prependSingleLineComment comment sub)
| Sequence (config, hd :: tl) when config.break = Always_rec ->
Sequence (config, prependSingleLineComment comment hd :: tl)
| Whitespace (info, sub) ->
insertCommentIntoWhitespaceRegion comment info sub
| layout -> breakline (formatComment comment) layout
(* breakAncestors break ancestors above node, but not comment attachment
itself.*)
let appendComment ~breakAncestors layout comment =
let text = Comment.wrap comment in
let layout =
match layout with
| Layout.Whitespace (info, sublayout) ->
Layout.Whitespace
( info
, makeList
~break:Layout.Never
~postSpace:true
[ sublayout; atom text ] )
| layout ->
makeList ~break:Layout.Never ~postSpace:true [ layout; atom text ]
in
if breakAncestors
then
makeList
~inline:(true, true)
~postSpace:false
~preSpace:true
~indent:0
~break:Always_rec
[ layout ]
else layout
(** * [looselyAttachComment layout comment] preorderly walks the layout and
* find a place where the comment can be loosely attached to *)
let rec looselyAttachComment ~breakAncestors layout comment =
let location = Comment.location comment in
match layout with
| Layout.SourceMap (loc, sub) ->
Layout.SourceMap (loc, looselyAttachComment ~breakAncestors sub comment)
| Layout.Whitespace (info, sub) ->
Layout.Whitespace
(info, looselyAttachComment ~breakAncestors sub comment)
| Easy _ -> inline ~postSpace:true layout (formatComment comment)
| Sequence (listConfig, subLayouts)
when List.exists ~f:(Layout.contains_location ~location) subLayouts ->
(* If any of the subLayout strictly contains this comment, recurse into
to it *)
let recurse_sublayout layout =
if Layout.contains_location layout ~location
then looselyAttachComment ~breakAncestors layout comment
else layout
in
Sequence (listConfig, List.map ~f:recurse_sublayout subLayouts)
| Sequence (listConfig, subLayouts) when subLayouts == [] ->
(* If there are no subLayouts (empty body), create a Sequence of just
the comment *)
Sequence (listConfig, [ formatComment comment ])
| Sequence (listConfig, subLayouts) ->
let beforeComment, afterComment =
Reason_syntax_util.pick_while (Layout.is_before ~location) subLayouts
in
let newSubLayout =
match List.rev beforeComment with
| [] ->
Reason_syntax_util.map_first
(prependSingleLineComment comment)
afterComment
| hd :: tl ->
List.rev_append
(appendComment ~breakAncestors hd comment :: tl)
afterComment
in
Sequence (listConfig, newSubLayout)
| Label (formatter, left, right) ->
let newLeft, newRight =
match Layout.get_location left, Layout.get_location right with
| None, None ->
left, looselyAttachComment ~breakAncestors right comment
| _, Some loc2 when Reason_syntax_util.location_contains loc2 location
->
left, looselyAttachComment ~breakAncestors right comment
| Some loc1, _ when Reason_syntax_util.location_contains loc1 location
->
looselyAttachComment ~breakAncestors left comment, right
| Some loc1, Some _
when Reason_syntax_util.location_is_before location loc1 ->
prependSingleLineComment comment left, right
| Some _, Some loc2
when Reason_syntax_util.location_is_before location loc2 ->
left, prependSingleLineComment comment right
| _ -> left, appendComment ~breakAncestors right comment
in
Label (formatter, newLeft, newRight)
(** * [insertSingleLineComment layout comment] preorderly walks the layout
and * find a place where the SingleLineComment can be fit into *)
let rec insertSingleLineComment layout comment =
let location = Comment.location comment in
match layout with
| Layout.SourceMap (loc, sub) ->
Layout.SourceMap (loc, insertSingleLineComment sub comment)
| Layout.Whitespace (info, sub) ->
let range = WhitespaceRegion.range info in
if Range.containsLoc range location
then insertCommentIntoWhitespaceRegion comment info sub
else Layout.Whitespace (info, insertSingleLineComment sub comment)
| Easy _ -> prependSingleLineComment comment layout
| Sequence (listConfig, subLayouts) when subLayouts == [] ->
(* If there are no subLayouts (empty body), create a Sequence of just the
* comment. We need to be careful when the empty body contains a //-style
* comment. Example:
* let make = () => {
* //
* };
* It is clear that the sequence needs to always break here, otherwise
* we get a parse error: let make = () => { // };
* The closing brace and semicolon `};` would become part of the comment…
*)
let listConfig =
if Reason_comment.isLineComment comment
then { listConfig with break = Always_rec }
else listConfig
in
Sequence (listConfig, [ formatComment comment ])
| Sequence (listConfig, subLayouts) ->
let beforeComment, afterComment =
Reason_syntax_util.pick_while (Layout.is_before ~location) subLayouts
in
(match afterComment with
(* Nothing in the list is after comment, attach comment to the statement
before the comment *)
| [] ->
let break sublayout = breakline sublayout (formatComment comment) in
Sequence (listConfig, Reason_syntax_util.map_last break beforeComment)
| hd :: tl ->
let afterComment =
match Layout.get_location hd with
| Some loc when Reason_syntax_util.location_contains loc location ->
insertSingleLineComment hd comment :: tl
| Some loc ->
Layout.SourceMap (loc, prependSingleLineComment comment hd) :: tl
| _ -> prependSingleLineComment comment hd :: tl
in
Sequence (listConfig, beforeComment @ afterComment))
| Label (formatter, left, right) ->
let leftLoc = Layout.get_location left in
let rightLoc = Layout.get_location right in
let newLeft, newRight =
match leftLoc, rightLoc with
| None, None -> left, insertSingleLineComment right comment
| _, Some loc2 when Reason_syntax_util.location_contains loc2 location
->
left, insertSingleLineComment right comment
| Some loc1, _ when Reason_syntax_util.location_contains loc1 location
->
insertSingleLineComment left comment, right
| Some loc1, Some _
when Reason_syntax_util.location_is_before location loc1 ->
prependSingleLineComment comment left, right
| Some _, Some loc2
when Reason_syntax_util.location_is_before location loc2 ->
left, prependSingleLineComment comment right
| _ -> left, breakline right (formatComment comment)
in
Label (formatter, newLeft, newRight)
let rec attachCommentToNodeRight layout comment =
match layout with
| Layout.Sequence (config, sub) when snd config.wrap <> "" ->
(* jwalke: This is quite the abuse of the "wrap" config *)
let lwrap, rwrap = config.wrap in
let rwrap = rwrap ^ " " ^ Comment.wrap comment in
Layout.Sequence ({ config with wrap = lwrap, rwrap }, sub)
| Layout.SourceMap (loc, sub) ->
Layout.SourceMap (loc, attachCommentToNodeRight sub comment)
| layout -> inline ~postSpace:true layout (formatComment comment)
let rec attachCommentToNodeLeft comment layout =
match layout with
| Layout.Sequence (config, sub) when snd config.wrap <> "" ->
let lwrap, rwrap = config.wrap in
let lwrap = Comment.wrap comment ^ " " ^ lwrap in
Layout.Sequence ({ config with wrap = lwrap, rwrap }, sub)
| Layout.SourceMap (loc, sub) ->
Layout.SourceMap (loc, attachCommentToNodeLeft comment sub)
| layout -> Layout.Label (inlineLabel, formatComment comment, layout)
(* [tryPerfectlyAttachComment layout comment] postorderly walk the [layout] and tries
* to perfectly attach a comment with a layout node.
*
* Perfectly attach here means a comment's start location is equal to the node's end location
* and vice versa.
*
* If the comment can be perfectly attached to any layout node, returns (newLayout, None),
* meaning the comment is consumed. Otherwise returns the (unchangedLayout, Some comment),
* meaning the comment is not consumed.
*
* "perfect attachment" doesn't make sense for end of line comments:
*
* {
* x: 0,
* y: 0
* }
*
* One of these will be "perfectly attached" to the zero and the other won't.
* Why should the comma have such an influence? Trailing commas and semicolons
* may be inserted or removed, an we need end-of-line comments to never be
* impacted by that. Therefore, never try to "perfectly" attach EOL comments.
*)
let rec tryPerfectlyAttachComment layout = function
| None -> layout, None
| Some comment -> perfectlyAttachComment comment layout
and perfectlyAttachComment comment = function
| Layout.Sequence (listConfig, subLayouts) ->
let distributeCommentIntoSubLayouts (i, processed, newComment) layout =
let layout, newComment =
tryPerfectlyAttachComment layout newComment
in
i + 1, layout :: processed, newComment
in
let _, processed, consumed =
List.fold_left
(List.rev subLayouts)
~init:(0, [], Some comment)
~f:distributeCommentIntoSubLayouts
in
Layout.Sequence (listConfig, processed), consumed
| Layout.Label (labelFormatter, left, right) ->
let newRight, comment = perfectlyAttachComment comment right in
let newLeft, comment = tryPerfectlyAttachComment left comment in
Layout.Label (labelFormatter, newLeft, newRight), comment
| Layout.SourceMap (loc, subLayout) ->
let commloc = Comment.location comment in
if
loc.loc_end.Lexing.pos_lnum = loc.loc_start.Lexing.pos_lnum
&& commloc.loc_start.Lexing.pos_cnum = loc.loc_end.Lexing.pos_cnum
then
( Layout.SourceMap
( loc
, makeList
~inline:(true, true)
~break:Always
[ unbreaklayout (attachCommentToNodeRight subLayout comment) ]
)
, None )
else
let layout, comment = perfectlyAttachComment comment subLayout in
(match comment with
| None -> Layout.SourceMap (loc, layout), None
| Some comment ->
if commloc.loc_end.Lexing.pos_cnum = loc.loc_start.Lexing.pos_cnum
then
( Layout.SourceMap (loc, attachCommentToNodeLeft comment layout)
, None )
else if
commloc.loc_start.Lexing.pos_cnum = loc.loc_end.Lexing.pos_cnum
then
( Layout.SourceMap (loc, attachCommentToNodeRight layout comment)
, None )
else Layout.SourceMap (loc, layout), Some comment)
| Whitespace (info, subLayout) ->
(match perfectlyAttachComment comment subLayout with
| newLayout, None -> Whitespace (info, newLayout), None
| newLayout, Some c -> Whitespace (info, newLayout), Some c)
| layout -> layout, Some comment
let insertRegularComment layout comment =
match perfectlyAttachComment comment layout with
| layout, None -> layout
| layout, Some _ ->
looselyAttachComment ~breakAncestors:false layout comment
let insertEndOfLineComment layout comment =
looselyAttachComment ~breakAncestors:true layout comment
let rec partitionComments_ ((singleLines, endOfLines, regulars) as soFar)
= function
| [] -> soFar
| com :: tl ->
(match Comment.category com with
| Comment.EndOfLine ->
partitionComments_ (singleLines, com :: endOfLines, regulars) tl
| Comment.SingleLine ->
partitionComments_ (com :: singleLines, endOfLines, regulars) tl
| Comment.Regular ->
partitionComments_ (singleLines, endOfLines, com :: regulars) tl)
let partitionComments comments =
let singleLines, endOfLines, regulars =
partitionComments_ ([], [], []) comments
in
singleLines, List.rev endOfLines, regulars
(* * Partition single line comments based on a location into two lists: * -
one contains the comments before/same height of that location * - the
other contains the comments after the location *)
let partitionSingleLineComments loc singleLineComments =
let before, after =
List.fold_left
singleLineComments
~init:([], [])
~f:(fun (before, after) comment ->
let cl = Comment.location comment in
let isAfter = loc.loc_end.pos_lnum < cl.loc_start.pos_lnum in
if isAfter
then before, comment :: after
else comment :: before, after)
in
List.rev before, after
(* * appends all [singleLineComments] after the [layout]. * [loc] marks the
end of [layout] *)
let appendSingleLineCommentsToEnd loc layout singleLineComments =
let rec aux prevLoc layout i = function
| comment :: cs ->
let loc = Comment.location comment in
let formattedComment = formatComment comment in
let commentLayout =
if Reason_location.hasSpaceBetween loc prevLoc
then insertBlankLines 1 formattedComment
else formattedComment
in
(* The initial layout breaks ugly with `breakline`, * an inline list
(that never breaks) fixes this *)
let newLayout =
if i == 0
then
makeList
~inline:(true, true)
~break:Never
[ layout; commentLayout ]
else breakline layout commentLayout
in
aux loc newLayout (i + 1) cs
| [] -> layout
in
aux loc layout 0 singleLineComments
(* * For simplicity, the formatting of comments happens in two parts in
context of a source map: * 1) insert the singleLineComments with the
interleaving algorithm contained in * `insertSingleLineComment` for all
comments overlapping with the sourcemap. * A `Layout.Whitespace` node
signals an intent to preserve whitespace here. * 2) SingleLineComments
after the sourcemap, e.g. at the end of .re/.rei file, * get attached
with `appendSingleLineCommentsToEnd`. Due to the fact there * aren't any
real ocaml ast nodes anymore after the sourcemap (end of a * file), the
printing of the comments can be done in one pass with *
`appendSingleLineCommentsToEnd`. This is more performant and * simplifies
the implementation of comment attachment. *)
let attachSingleLineComments singleLineComments = function
| Layout.SourceMap (loc, subLayout) ->
let before, after =
partitionSingleLineComments loc singleLineComments
in
let layout =
List.fold_left before ~init:subLayout ~f:insertSingleLineComment
in
appendSingleLineCommentsToEnd loc layout after
| layout ->
List.fold_left
singleLineComments
~init:layout
~f:insertSingleLineComment
let format_layout ?comments ppf layout =
let easy =
match comments with
| None -> Layout.to_easy_format layout
| Some comments ->
let singleLines, endOfLines, regulars = partitionComments comments in
(* TODO: Stop generating multiple versions of the tree, and instead
generate one new tree. *)
(* Layout.dump Format.std_formatter layout; *)
let layout =
List.fold_left regulars ~init:layout ~f:insertRegularComment
in
let layout = consolidateSeparator layout in
let layout =
List.fold_left endOfLines ~init:layout ~f:insertEndOfLineComment
in
(* Layout.dump Format.std_formatter layout; *)
let layout = attachSingleLineComments singleLines layout in
(* Layout.dump Format.std_formatter layout; *)
let layout = insertLinesAboveItems layout in
let layout = Layout.to_easy_format layout in
(* Layout.dump_easy Format.std_formatter layout; *)
layout
in
let buf = Buffer.create 1000 in
let fauxmatter = Format.formatter_of_buffer buf in
let _ = Format.pp_set_margin fauxmatter settings.width in
if debugWithHtml.contents
then Easy_format.Pretty.define_styles fauxmatter html_escape html_style;
let _ = Easy_format.Pretty.to_formatter fauxmatter easy in
let trimmed =
Reason_syntax_util.processLineEndingsAndStarts (Buffer.contents buf)
in
Format.fprintf ppf "%s\n" trimmed;
Format.pp_print_flush ppf ()
let rev_and_len xs =
let rec rev_and_len acc len xs =
match xs with
| [] -> acc, len
| x :: xs -> rev_and_len (x :: acc) (len + 1) xs
in
rev_and_len [] 0 xs
let partitionFinalWrapping listTester wrapFinalItemSetting x =
let rev, len = rev_and_len x in
match rev, wrapFinalItemSetting with
| [], _ ->
raise (NotPossible "shouldnt be partitioning 0 label attachments")
| _, NeverWrapFinalItem -> None
| last :: revEverythingButLast, WrapFinalListyItemIfFewerThan max ->
if (not (listTester last)) || len >= max
then None
else Some (List.rev revEverythingButLast, last)
let semiTerminated term = makeList [ term; atom ";" ]
(* postSpace is so that when comments are interleaved, we still use spacing
rules. *)
let makeLetSequence ?(wrap = "{", "}") letItems =
makeList
~break:Always_rec
~inline:(true, false)
~wrap
~postSpace:true
~sep:(SepFinal (";", ";"))
letItems
let makeLetSequenceSingleLine ?(wrap = "{", "}") letItems =
makeList
~break:IfNeed
~inline:(true, false)
~wrap
~preSpace:true
~postSpace:true
~sep:(Sep ";")
letItems
(* postSpace is so that when comments are interleaved, we still use spacing
rules. *)
let makeUnguardedLetSequence ?(sep = Layout.SepFinal (";", ";")) letItems =
makeList
~break:Always_rec
~inline:(true, true)
~wrap:("", "")
~indent:0
~postSpace:true
~sep
letItems
let formatSimpleAttributed x y =
makeList
~wrap:("(", ")")
~break:IfNeed
~indent:0
~postSpace:true
(List.concat [ y; [ x ] ])
let formatAttributed ?(labelBreak = `Auto) x y =
label
~break:labelBreak
~indent:0
~space:true
(makeList ~inline:(true, true) ~postSpace:true y)
x
(* For when the type constraint should be treated as a separate breakable
line item itself not docked to some value/pattern label. fun x y :
retType => blah; *)
let formatJustTheTypeConstraint typ =
makeList ~postSpace:false ~sep:(Sep " ") [ atom ":"; typ ]
let formatTypeConstraint one two =
label ~space:true (makeList ~postSpace:false [ one; atom ":" ]) two
let formatJustCoerce optType coerced =
match optType with
| None -> makeList ~postSpace:false ~sep:(Sep " ") [ atom ":>"; coerced ]
| Some typ ->
label ~space:true (makeList ~postSpace:true [ typ; atom ":>" ]) coerced
let formatCoerce expr optType coerced =
match optType with
| None ->
label ~space:true (makeList ~postSpace:true [ expr; atom ":>" ]) coerced
| Some typ ->
label
~space:true
(makeList
~postSpace:true
[ formatTypeConstraint expr typ; atom ":>" ])
coerced
(* Standard function application style indentation - no special wrapping *
behavior. * * Formats like this: * * let result = * someFunc * (10, 20);
* * * Instead of this: * * let result = * someFunc ( * 10, * 20 * ); * *
The outer list wrapping fixes #566: format should break the whole *
application before breaking arguments. *)
let formatIndentedApplication headApplicationItem argApplicationItems =
makeList
~inline:(true, true)
~postSpace:true
~break:IfNeed
[ label
~space:true
headApplicationItem
(makeAppList argApplicationItems)
]
(* The loc, is an optional location or the returned app terms *)
let formatAttachmentApplication
finalWrapping
(attachTo : (bool * Layout.t) option)
(appTermItems, loc)
=
let partitioning = finalWrapping appTermItems in
match partitioning with
| None ->
(match appTermItems, attachTo with
| [], _ -> raise (NotPossible "No app terms")
| [ hd ], None -> source_map ?loc hd
| [ hd ], Some (useSpace, toThis) ->
label ~space:useSpace toThis (source_map ?loc hd)
| hd :: tl, None -> source_map ?loc (formatIndentedApplication hd tl)
| hd :: tl, Some (useSpace, toThis) ->
label
~space:useSpace
toThis
(source_map ?loc (formatIndentedApplication hd tl)))
| Some (attachedList, wrappedListy) ->
(match attachedList, attachTo with
| [], Some (useSpace, toThis) ->
label ~space:useSpace toThis (source_map ?loc wrappedListy)
| [], None ->
(* Not Sure when this would happen *)
source_map ?loc wrappedListy
| _ :: _, Some (useSpace, toThis) ->
(* TODO: Can't attach location to this - maybe rewrite anyways *)
let attachedArgs = makeAppList attachedList in
label
~space:useSpace
toThis
(label ~space:true attachedArgs wrappedListy)
| _ :: _, None ->
(* Args that are "attached to nothing" *)
let appList = makeAppList attachedList in
source_map ?loc (label ~space:true appList wrappedListy))
(* Preprocesses an expression term for the sake of label attachments ([letx
= expr]or record [field: expr]). Function application should have special
treatment when placed next to a label. (The invoked function term should
"stick" to the label in some cases). In others, the invoked function term
should become a new label for the remaining items to be indented
under. *)
let applicationFinalWrapping x =
partitionFinalWrapping isSequencey settings.funcApplicationLabelStyle x
let curriedFunctionFinalWrapping x =
partitionFinalWrapping isSequencey settings.funcCurriedPatternStyle x
let typeApplicationFinalWrapping typeApplicationItems =
partitionFinalWrapping
isSequencey
settings.funcApplicationLabelStyle
typeApplicationItems
let add_raw_identifier_prefix txt =
let prefix =
match Hashtbl.find Reason_declarative_lexer.keyword_table txt with
| _ -> "\\#"
| exception Not_found -> ""
in
prefix ^ txt
(* add parentheses to binders when they are in fact infix or prefix
operators *)
let protectIdentifier txt =
let needs_parens = needs_parens txt in
let txt =
if Reason_syntax_util.is_andop txt || Reason_syntax_util.is_letop txt
then Reason_syntax_util.compress_letop_identifier txt
(* Don't add \# prefix if we're adding parens - parens already protect
keywords like (mod) from being parsed as keywords *)
else if needs_parens
then txt
else txt |> add_raw_identifier_prefix
in
if not needs_parens
then atom txt
else if needs_spaces txt
then makeList ~wrap:("(", ")") ~pad:(true, true) [ atom txt ]
else atom ("(" ^ txt ^ ")")
let protectLongIdentifier longPrefix txt =
makeList [ longPrefix; atom "."; protectIdentifier txt ]
let paren b fu ppf x =
if b then Format.fprintf ppf "(%a)" fu x else fu ppf x
let constant_string_for_primitive ppf s =
let hasQuote = try String.index s '"' with Not_found -> -1 in
let hasNewline = try String.index s '\n' with Not_found -> -1 in
if hasQuote > -1 || hasNewline > -1
then Format.fprintf ppf "{|%s|}" s
else Format.fprintf ppf "%S" s
let tyvar ppf str = Format.fprintf ppf "'%s" str
(* In some places parens shouldn't be printed for readability: * e.g.
Some((-1)) should be printed as Some(-1) * In `1 + (-1)` -1 should be
wrapped in parens for readability *)
let constant ?raw_literal ?(parens = true) ppf = function
| Pconst_char i -> Format.fprintf ppf "%C" i
| Pconst_string (i, _, None) ->
(match raw_literal with
| Some text -> Format.fprintf ppf "\"%s\"" text
| None ->
Format.fprintf ppf "\"%s\"" (Reason_syntax_util.escape_string i))
| Pconst_string (i, _, Some delim) ->
Format.fprintf ppf "{%s|%s|%s}" delim i delim
| Pconst_integer (i, None) ->
paren (parens && i.[0] = '-') (fun ppf -> Format.fprintf ppf "%s") ppf i
| Pconst_integer (i, Some m) ->
paren
(parens && i.[0] = '-')
(fun ppf (i, m) -> Format.fprintf ppf "%s%c" i m)
ppf
(i, m)
| Pconst_float (i, None) ->
paren (parens && i.[0] = '-') (fun ppf -> Format.fprintf ppf "%s") ppf i
| Pconst_float (i, Some m) ->
paren
(parens && i.[0] = '-')
(fun ppf (i, m) -> Format.fprintf ppf "%s%c" i m)
ppf
(i, m)
let is_punned_labelled_pattern_no_attrs p lbl =
match p.ppat_attributes, p.ppat_desc with
| _ :: _, _ -> false
| ( []
, Ppat_constraint
({ ppat_desc = Ppat_var { txt; _ }; ppat_attributes = []; _ }, _) )
| [], Ppat_var { txt; _ } ->
txt = lbl
| _ -> false
let isLongIdentWithDot = function Ldot _ -> true | _ -> false
(* Js.t -> useful for Melange syntax sugar: `Js.t({. foo: bar})` -> `{.
"foo": bar}` *)
let isJsDotTLongIdent ident =
match ident with Ldot (Lident "Js", "t") -> true | _ -> false
let recordRowIsPunned pld =
let name = pld.pld_name.txt in
match pld.pld_type with
| { ptyp_desc =
Ptyp_constr
( { txt; _ }
, (* don't pun parameterized types, e.g. {tag: tag 'props} *)
[] )
; (* Don't pun types that have attributes attached, e.g. { foo: [@bar]
foo } *)
ptyp_attributes = []
; _
}
when Longident.last_exn txt = name
(* Don't pun types from other modules, e.g. type bar = {foo:
Baz.foo}; *)
&& isLongIdentWithDot txt == false ->
true
| _ -> false
let isPunnedJsxArg lbl ident attr =
(not (isLongIdentWithDot ident.txt))
&& Longident.last_exn ident.txt = lbl
&& attr = []
let is_unit_pattern x =
match x.ppat_desc with
| Ppat_construct ({ txt = Lident "()"; _ }, None) -> true
| _ -> false
let is_ident_pattern x =
match x.ppat_desc with Ppat_var _ -> true | _ -> false
let is_any_pattern x = x.ppat_desc = Ppat_any
let is_direct_pattern x =
x.ppat_attributes == []
&&
match x.ppat_desc with
| Ppat_construct ({ txt = Lident "()"; _ }, None) -> true
| _ -> false
let isJSXComponent expr =
match expr with
| { pexp_desc = Pexp_apply ({ pexp_desc = Pexp_ident _; _ }, args)
; pexp_attributes
; _
}
| { pexp_desc =
Pexp_apply ({ pexp_desc = Pexp_letmodule (_, _, _); _ }, args)
; pexp_attributes
; _
} ->
let { Reason_attributes.jsxAttrs; _ } =
Reason_attributes.partitionAttributes pexp_attributes
in
let hasLabelledChildrenLiteral =
List.exists
~f:(function Labelled "children", _ -> true | _ -> false)
args
in
let rec hasSingleNonLabelledUnitAndIsAtTheEnd l =
match l with
| [] -> false
| ( Nolabel
, { pexp_desc = Pexp_construct ({ txt = Lident "()"; _ }, _); _ } )
:: [] ->
true
| (Nolabel, _) :: _ -> false
| _ :: rest -> hasSingleNonLabelledUnitAndIsAtTheEnd rest
in
if
jsxAttrs != []
&& hasLabelledChildrenLiteral
&& hasSingleNonLabelledUnitAndIsAtTheEnd args
then true
else false
| _ -> false
(* Some cases require special formatting when there's a function application
* with a single argument containing some kind of structure with braces/parens/brackets.
* Example: `foo({a: 1, b: 2})` needs to be formatted as
* foo({
* a: 1,
* b: 2
* })
* when the line length dictates breaking. Notice how `({` and `})` 'hug'.
* Also applies to (poly)variants because they can be seen as a form of "function application".
* This function says if a list of expressions fulfills the need to be formatted like
* the example above. *)
let isSingleArgParenApplication = function
| [ { pexp_attributes = []; pexp_desc = Pexp_record _; _ } ]
| [ { pexp_attributes = []; pexp_desc = Pexp_tuple _; _ } ]
| [ { pexp_attributes = []; pexp_desc = Pexp_array _; _ } ]
| [ { pexp_attributes = []; pexp_desc = Pexp_object _; _ } ] ->
true
| [ { pexp_attributes = []; pexp_desc = Pexp_extension (s, _); _ } ]
when s.txt = "mel.obj" ->
true
| [ ({ pexp_attributes = []; _ } as exp) ] when is_simple_list_expr exp ->
true
| _ -> false
(* Determines if the arguments of a constructor pattern match need
* special printing. If there's one argument & they have some kind of wrapping,
* they're wrapping need to 'hug' the surrounding parens.
* Example:
* switch x {
* | Some({
* a,
* b,
* }) => ()
* }
*
* Notice how ({ and }) hug.
* This applies for records, arrays, tuples & lists.
* See `singleArgParenPattern` for the acutal formatting
*)
let isSingleArgParenPattern = function
| [ { ppat_attributes = []; ppat_desc = Ppat_record _; _ } ]
| [ { ppat_attributes = []; ppat_desc = Ppat_array _; _ } ]
| [ { ppat_attributes = []; ppat_desc = Ppat_tuple _; _ } ] ->
true
| [ { ppat_attributes = []
; ppat_desc = Ppat_construct ({ txt = Lident "::"; _ }, _)
; _
}
] ->
true
| _ -> false
(* Flattens a resolvedRule into a list of infixChain nodes. * When foo |> f
|> z gets parsed, we get the following tree: * |> * / \ * foo |> * / \ *
f z * To format this recursive tree in a way that allows nice breaking *
& respects the print-width, we need some kind of flattened * version of
the above tree. `computeInfixChain` transforms the tree * in a flattened
version which allows flexible formatting. * E.g. we get * [LayoutNode
foo; InfixToken |>; LayoutNode f; InfixToken |>; LayoutNode z] *)
let rec computeInfixChain = function
| LayoutNode layoutNode -> [ Layout layoutNode ]
| InfixTree (op, leftResolvedRule, rightResolvedRule) ->
computeInfixChain leftResolvedRule
@ [ InfixToken op ]
@ computeInfixChain rightResolvedRule
let equalityOperators = [ "!="; "!=="; "==="; "=="; ">="; "<="; "<"; ">" ]
(* Formats a flattened list of infixChain nodes into a list of layoutNodes *
which allow smooth line-breaking * e.g. [LayoutNode foo; InfixToken |>;
LayoutNode f; InfixToken |>; LayoutNode z] * becomes * [ * foo * ; |> f
--> label * ; |> z --> label * ] * If you make a list out of this items,
we get smooth line breaking * foo |> f |> z * becomes * foo * |> f * |> z
* when the print-width forces line breaks. *)
let formatComputedInfixChain infixChainList =
let layout_of_group group currentToken =
(* Represents the `foo` in * foo * |> f * |> z *)
match group with
| [] | [ _ ] -> makeList ~inline:(true, true) ~sep:(Sep " ") group
| _ ->
(* Basic equality operators require special formatting, we can't give
it * 'classic' infix operator formatting, otherwise we would get *
let example = * true * != false * && "a" * == "b" * *)
if List.mem currentToken ~set:equalityOperators
then
let hd = List.hd group in
let tl =
makeList ~inline:(true, true) ~sep:(Sep " ") (List.tl group)
in
makeList
~inline:(true, true)
~sep:(Sep " ")
~break:IfNeed
[ hd; tl ]
else if currentToken.[0] = '#'
then
let isSharpEqual = currentToken = sharpOpEqualToken in
makeList ~postSpace:isSharpEqual group
else
(* Represents `|> f` in foo |> f * We need a label here to indent
possible closing parens * on the same height as the infix
operator * e.g. * >|= ( * fun body => * Printf.sprintf * "okokok"
uri meth headers body * ) <-- notice how this closing paren is on
the same height as >|= *)
label
~break:`Never
~space:true
(atom currentToken)
(List.nth group 1)
in
let rec print acc group currentToken l =
match l with
| x :: xs ->
(match x with
| InfixToken t ->
(* = or := *)
if List.mem t ~set:requireIndentFor
then
let groupNode =
makeList
~inline:(true, true)
~sep:(Sep " ")
(print [] group currentToken [] @ [ atom t ])
in
let children =
makeList
~inline:(true, true)
~preSpace:true
~break:IfNeed
(print [] [] t xs)
in
print (acc @ [ label ~space:true groupNode children ]) [] t []
(* Represents:
* List.map @@
* List.length
*
* Notice how we want the `@@` on the first line.
* Extra indent puts pressure on the subsequent line lengths
*)
else if t = "@@"
then
let groupNode =
makeList ~inline:(true, true) ~sep:(Sep " ") (group @ [ atom t ])
in
print (acc @ [ groupNode ]) [] t xs
(* != !== === == >= <= < > etc *)
else if List.mem t ~set:equalityOperators
then print acc (print [] group currentToken [] @ [ atom t ]) t xs
else if requireNoSpaceFor t
then
if currentToken = "" || requireNoSpaceFor currentToken
then print acc (group @ [ atom t ]) t xs
else
(* a + b + foo##bar##baz * `foo` needs to be picked from the
current group * and inserted into a new one. This way `foo` *
gets the special "chained"-printing: * foo##bar##baz. *)
match List.rev group with
| hd :: tl ->
let acc =
acc @ [ layout_of_group (List.rev tl) currentToken ]
in
print acc [ hd; atom t ] t xs
| [] -> print acc (group @ [ atom t ]) t xs
else
print
(acc @ [ layout_of_group group currentToken ])
[ atom t ]
t
xs
| Layout layoutNode ->
print acc (group @ [ layoutNode ]) currentToken xs)
| [] ->
if List.mem currentToken ~set:requireIndentFor
then acc @ group
else acc @ [ layout_of_group group currentToken ]
in
let l = print [] [] "" infixChainList in
makeList ~inline:(true, true) ~sep:(Sep " ") ~break:IfNeed l
(** * [groupAndPrint] will print every item in [items] according to the
function [xf]. * [getLoc] will extract the location from an item. Based
on the difference * between the location of two items, if there's
whitespace between the two * (taken possible comments into account),
items get grouped. * Every group designates a series of layout nodes "in
need * of whitespace above". A group gets decorated with a Whitespace
node * containing enough info to interleave whitespace at a later time
during * printing. *)
let groupAndPrint ~xf ~getLoc ~comments items =
let rec group prevLoc curr acc = function
(* group items *)
| x :: xs ->
let item = xf x in
let loc = getLoc x in
(* Get the range between the current and previous item * Example: * 1|
let a = 1; * 2| --> this is the range between the two * 3| let b =
2; * *)
let range = Range.makeRangeBetween prevLoc loc in
(* If there's whitespace interleaved, append the new layout node * to
a new group, otherwise keep it in the current group. * Takes
possible comments interleaved into account. * * Example: * 1| let a
= 1; * 2| * 3| let b = 2; * 4| let c = 3; * `let b = 2` will mark
the start of a new group * `let c = 3` will be added to the group
containing `let b = 2` *)
if Range.containsWhitespace ~range ~comments ()
then group loc [ range, item ] (List.rev curr :: acc) xs
else group loc ((range, item) :: curr) acc xs
(* convert groups into "Layout.Whitespace" *)
| [] ->
let groups = List.rev (List.rev curr :: acc) in
List.mapi
~f:(fun i group ->
match group with
| curr :: xs ->
let range, x = curr in
(* if this is the first group of all "items", the number of
* newlines interleaved should be 0, else we collapse all newlines
* to 1.
*
* Example:
* module Abc = {
* let a = 1;
*
* let b = 2;
* }
* `let a = 1` should be wrapped in a `Layout.Whitespace` because a
* user might put comments above the `let a = 1`.
* e.g.
* module Abc = {
* /* comment 1 */
*
* /* comment 2 */
* let a = 1;
*
* A Whitespace-node will automatically take care of the whitespace
* interleaving between the comments.
*)
let newlines = if i > 0 then 1 else 0 in
let region = WhitespaceRegion.make ~range ~newlines in
let firstLayout = Layout.Whitespace (region, x) in
(* the first layout node of every group taks care of the *
whitespace above a group*)
firstLayout :: List.map ~f:snd xs
| [] -> [])
groups
in
match items with
| first :: rest ->
List.concat (group (getLoc first) [] [] (first :: rest))
| [] -> []
let printer =
object (self : 'self)
val pipe = false
val semi = false
val inline_braces = false
val preserve_braces = true
(* *Mutable state* in the printer to keep track of all comments * Used
when whitespace needs to be interleaved. * The printing algorithm
needs to take the comments into account in between * two items, to
correctly determine if there's whitespace between two items. * The
ast doesn't know if there are comments between two items, since *
comments are store separately. The location diff between two items *
might indicate whitespace between the two. While in reality there are
* comments filling that whitespace. The printer needs access to the
comments * for this reason. * * Example: * 1| let a = 1; * 2| * 3| *
4| let b = 2; * -> here we can just diff the locations between `let a
= 1` and `let b = 2` * * 1| let a = 1; * 2| /* a comment */ * 3| /*
another comment */ * 4| let b = 2; * -> here the location diff will
result into false info if we don't include * the comments in the
diffing *)
val mutable comments = []
method comments = comments
method trackComment comment = comments <- comment :: comments
(* The test and first branch of ternaries must be guarded *)
method under_pipe = {<pipe = true>}
method under_semi = {<semi = true>}
method reset_semi = {<semi = false>}
method reset_pipe = {<pipe = false>}
method reset = {<pipe = false; semi = false>}
method inline_braces = {<inline_braces = true>}
method dont_preserve_braces = {<preserve_braces = false>}
method reset_request_braces =
{<inline_braces = false; preserve_braces = true>}
method longident =
function
| Lident s -> protectIdentifier s
| Ldot (longPrefix, s) ->
protectLongIdentifier (self#longident longPrefix) s
| Lapply (y, s) ->
makeList [ self#longident y; atom "("; self#longident s; atom ")" ]
(* This form allows applicative functors. *)
method longident_class_or_type_loc x = self#longident x.txt
(* TODO: Fail if observing applicative functors for this form. *)
method longident_loc (x : Longident.t Location.loc) =
source_map ~loc:x.loc (self#longident x.txt)
method constant ?raw_literal ?(parens = true) =
wrap (constant ?raw_literal ~parens)
method constant_string_for_primitive =
wrap constant_string_for_primitive
method tyvar = wrap tyvar
(* c ['a,'b] *)
method class_params_def =
function
| [] -> atom ""
| l -> makeTup (List.map ~f:self#type_param l)
(* This will fall through to the simple version. *)
method non_arrowed_core_type x = self#non_arrowed_non_simple_core_type x
method core_type2 x =
let { Reason_attributes.stdAttrs; uncurried; _ } =
Reason_attributes.partitionAttributes x.ptyp_attributes
in
let uncurried =
uncurried
||
try Hashtbl.find uncurriedTable x.ptyp_loc with
| Not_found -> false
in
if stdAttrs != []
then
formatAttributed
(self#non_arrowed_simple_core_type
{ x with ptyp_attributes = [] })
(self#attributes stdAttrs)
else
let x = if uncurried then { x with ptyp_attributes = [] } else x in
match x.ptyp_desc with
| Ptyp_arrow _ ->
let rec allArrowSegments ?(uncurried = false) acc = function
| { ptyp_desc = Ptyp_arrow (l, ct1, ct2)
; ptyp_attributes = []
; _
} ->
allArrowSegments
~uncurried:false
((l, ct1, false || uncurried) :: acc)
ct2
| rhs ->
let rhs = self#core_type2 rhs in
let is_tuple typ =
match typ.ptyp_desc with Ptyp_tuple _ -> true | _ -> false
in
(match acc with
| [ (Nolabel, lhs, uncurried) ] when not (is_tuple lhs) ->
let t = self#non_arrowed_simple_core_type lhs in
let lhs =
if uncurried
then makeList ~wrap:("(. ", ")") ~postSpace:true [ t ]
else t
in
lhs, rhs
| acc ->
let params = List.rev_map ~f:self#type_with_label acc in
makeCommaBreakableListSurround "(" ")" params, rhs)
in
let lhs, rhs = allArrowSegments ~uncurried [] x in
let normalized =
makeList
~preSpace:true
~postSpace:true
~inline:(true, true)
~break:IfNeed
~sep:(Sep "=>")
[ lhs; rhs ]
in
source_map ~loc:x.ptyp_loc normalized
| Ptyp_poly (sl, ct) ->
let ct = self#core_type ct in
let poly =
match sl with
| [] -> ct
| sl ->
makeList
~break:IfNeed
~postSpace:true
[ makeList
[ makeList
~postSpace:true
(List.map ~f:(fun { txt; _ } -> self#tyvar txt) sl)
; atom "."
]
; ct
]
in
source_map ~loc:x.ptyp_loc poly
| _ -> self#non_arrowed_core_type x
(* Same as core_type2 but can be aliased *)
method core_type x =
let { Reason_attributes.stdAttrs; uncurried; _ } =
Reason_attributes.partitionAttributes x.ptyp_attributes
in
let () =
if uncurried then Hashtbl.add uncurriedTable x.ptyp_loc true
in
if stdAttrs != []
then
formatAttributed
(self#non_arrowed_simple_core_type
{ x with ptyp_attributes = [] })
(self#attributes stdAttrs)
else
match x.ptyp_desc with
| Ptyp_alias (ct, s) ->
source_map
~loc:x.ptyp_loc
(label
~space:true
(self#core_type ct)
(makeList ~postSpace:true [ atom "as"; atom ("'" ^ s.txt) ]))
| _ -> self#core_type2 x
method type_with_label (lbl, c, uncurried) =
let typ = self#core_type c in
let t =
match lbl with
| Nolabel -> typ
| Labelled lbl ->
label ~space:true (atom (namedArgSym ^ lbl ^ ":")) typ
| Optional lbl ->
label
~space:true
(atom (namedArgSym ^ lbl ^ ":"))
(label typ (atom "=?"))
in
if uncurried then makeList ~postSpace:true [ atom "."; t ] else t
method type_param (ct, (a, _)) =
makeList [ atom (type_variance a); self#core_type ct ]
(* According to the parse rule [type_declaration], the "type
declaration"'s * physical location (as indicated by [td.ptype_loc])
begins with the * identifier and includes the constraints. *)
method formatOneTypeDef
prepend
name
assignToken
({ ptype_params; ptype_kind; ptype_loc; _ } as td) =
let equalInitiatedSegments, constraints =
self#type_declaration_binding_segments td
in
let formattedTypeParams = List.map ~f:self#type_param ptype_params in
let binding = makeList ~postSpace:true [ prepend; name ] in
(* /-----------everythingButConstraints-------------- |
-constraints--\ * /-innerL---|
------innerR--------------------------\ * /binding\ /typeparams\
/--equalInitiatedSegments-\ * type name 'v1 'v1 = foo = private bar
constraint a = b *)
let labelWithParams =
match formattedTypeParams with
| [] -> binding
| l -> label binding (makeTup l)
in
let everythingButConstraints =
let nameParamsEquals =
makeList ~postSpace:true [ labelWithParams; assignToken ]
in
match equalInitiatedSegments with
| [] -> labelWithParams
| _ :: _ :: _ :: _ ->
raise (NotPossible "More than two type segments.")
| hd :: [] ->
formatAttachmentApplication
typeApplicationFinalWrapping
(Some (true, nameParamsEquals))
(hd, None)
| [ hd; hd2 ] ->
let first =
makeList
~postSpace:true
~break:IfNeed
~inline:(true, true)
(hd @ [ atom "=" ])
in
(* Because we want a record as a label with the opening brace on the same line
* and the closing brace indented at the beginning, we can't wrap it in a list here
* Example:
* type doubleEqualsRecord =
* myRecordWithReallyLongName = { <- opening brace on the same line
* xx: int,
* yy: int
* }; <- closing brace indentation
*)
let second =
match ptype_kind with
| Ptype_record _ -> List.hd hd2
| _ ->
makeList
~postSpace:true
~break:IfNeed
~inline:(true, true)
hd2
in
label
~space:true
nameParamsEquals
(label ~space:true first second)
in
let everything =
match constraints with
| [] -> everythingButConstraints
| hd :: tl ->
makeList
~break:IfNeed
~postSpace:true
~indent:0
~inline:(true, true)
(everythingButConstraints :: hd :: tl)
in
source_map ~loc:ptype_loc everything
method formatOneTypeExt prepend name assignToken te =
let privateAtom = atom "pri" in
let privatize scope lst =
match scope with Public -> lst | Private -> privateAtom :: lst
in
let equalInitiatedSegments =
let segments =
List.map
~f:self#type_extension_binding_segments
te.ptyext_constructors
in
let privatized_segments = privatize te.ptyext_private segments in
[ makeList
~break:Always_rec
~postSpace:true
~inline:(true, true)
privatized_segments
]
in
let formattedTypeParams =
List.map ~f:self#type_param te.ptyext_params
in
let binding = makeList ~postSpace:true [ prepend; name ] in
let labelWithParams =
match formattedTypeParams with
| [] -> binding
| l -> label binding (makeTup l)
in
let everything =
let nameParamsEquals =
makeList ~postSpace:true [ labelWithParams; assignToken ]
in
formatAttachmentApplication
typeApplicationFinalWrapping
(Some (true, nameParamsEquals))
(equalInitiatedSegments, None)
in
source_map ~loc:te.ptyext_path.loc everything
method type_extension_binding_segments
{ pext_kind; pext_loc; pext_attributes; pext_name } =
let normalize lst =
match lst with
| [] -> raise (NotPossible "should not be called")
| [ hd ] -> hd
| _ :: _ -> makeList lst
in
let add_bar name attrs args =
let lbl =
match args with None -> name | Some args -> label name args
in
if attrs != []
then
label
~space:true
(makeList
~postSpace:true
[ atom "|"
; makeList
~postSpace:true
~break:Layout.IfNeed
~inline:(true, true)
(self#attributes attrs)
])
lbl
else makeList ~postSpace:true [ atom "|"; lbl ]
in
let sourceMappedName = atom ~loc:pext_name.loc pext_name.txt in
let resolved =
match pext_kind with
| Pext_decl (_, ctor_args, gadt) ->
let formattedArgs =
match ctor_args with
| Pcstr_tuple [] -> []
| Pcstr_tuple args ->
[ makeTup
(List.map ~f:self#non_arrowed_non_simple_core_type args)
]
| Pcstr_record r ->
[ self#record_declaration ~wrap:("({", "})") r ]
in
let formattedGadt =
match gadt with
| None -> None
| Some x ->
Some
(makeList
[ formatJustTheTypeConstraint (self#core_type x) ])
in
formattedArgs, formattedGadt
(* type bar += Foo = Attr.Foo *)
| Pext_rebind rebind ->
let r = self#longident_loc rebind in
(* we put an empty space before the '=': we don't have access to
the fact * that we need a space because of the Pext_rebind
later *)
let prepend = atom " =" in
[ makeList ~postSpace:true [ prepend; r ] ], None
in
(* * The first element of the tuple represents constructor arguments,
* the second an optional formatted gadt. * * Case 1: No constructor
arguments, neither a gadt * type attr = ..; * type attr += | Str *
* Case 2: No constructor arguments, is a gadt * type attr = ..; *
type attr += | Str :attr * * Case 3: Has Constructor args, not a
gadt * type attr = ..; * type attr += | Str(string); * type attr +=
| Point(int, int); * * Case 4: Has Constructor args & is a gadt *
type attr = ..; * type attr += | Point(int, int) :attr; *)
let everything =
match resolved with
| [], None -> add_bar sourceMappedName pext_attributes None
| [], Some gadt ->
add_bar sourceMappedName pext_attributes (Some gadt)
| ctorArgs, None ->
add_bar
sourceMappedName
pext_attributes
(Some (normalize ctorArgs))
| ctorArgs, Some gadt ->
add_bar
sourceMappedName
pext_attributes
(Some (normalize (ctorArgs @ [ gadt ])))
in
source_map ~loc:pext_loc everything
(* shared by [Pstr_type, Psig_type]*)
method type_def_list ?(eq_symbol = "=") ?extension rf l =
(* As oposed to used in type substitution. *)
let formatOneTypeDefStandard prepend td =
let itm =
self#formatOneTypeDef
prepend
(atom
~loc:td.ptype_name.loc
(add_raw_identifier_prefix td.ptype_name.txt))
(atom eq_symbol)
td
in
let { Reason_attributes.stdAttrs; docAttrs; _ } =
Reason_attributes.partitionAttributes
~partDoc:true
td.ptype_attributes
in
let layout = self#attach_std_item_attrs stdAttrs itm in
self#attachDocAttrsToLayout
~stdAttrs
~docAttrs
~loc:td.ptype_loc
~layout
()
in
match l with
| [] -> raise (NotPossible "asking for type list of nothing")
| hd :: tl ->
let first =
match rf with
| Recursive ->
let label = add_extension_sugar "type" extension in
formatOneTypeDefStandard (atom label) hd
| Nonrecursive -> formatOneTypeDefStandard (atom "type nonrec") hd
in
(match tl with
(* Exactly one type *)
| [] -> first
| _ :: _ as typeList ->
let items =
(hd.ptype_loc, first)
:: List.map
~f:(fun ptyp ->
( ptyp.ptype_loc
, formatOneTypeDefStandard (atom "and") ptyp ))
typeList
in
makeList
~indent:0
~inline:(true, true)
~break:Always_rec
(groupAndPrint
~xf:snd
~getLoc:fst
~comments:self#comments
items))
method type_variant_list lst =
match lst with
| [] -> [ atom "|" ]
| _ -> List.map ~f:(fun x -> self#type_variant_leaf x) lst
method type_variant_leaf
?opt_ampersand:(a = false)
?polymorphic:(p = false) =
self#type_variant_leaf1 a p true
method type_variant_leaf_nobar
?opt_ampersand:(a = false)
?polymorphic:(p = false) =
self#type_variant_leaf1 a p false
(* TODOATTRIBUTES: Attributes on the entire variant leaf are likely *
not parsed or printed correctly. *)
method type_variant_leaf1 opt_ampersand polymorphic print_bar x =
let { pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes; _ } = x in
let { Reason_attributes.stdAttrs; docAttrs; _ } =
Reason_attributes.partitionAttributes ~partDoc:true pcd_attributes
in
let ampersand_helper i arg =
let ct = self#core_type arg in
let ct =
match arg.ptyp_desc with
| Ptyp_tuple _ -> ct
| _ -> makeTup [ ct ]
in
if i == 0 && not opt_ampersand then ct else label (atom "&") ct
in
let args =
match pcd_args with
| Pcstr_record r -> [ self#record_declaration ~wrap:("({", "})") r ]
| Pcstr_tuple [] -> []
| Pcstr_tuple l when polymorphic -> List.mapi ~f:ampersand_helper l
(* Here's why this works. With the new syntax, all the args, are
already inside of a safely guarded place like Constructor(here,
andHere). Compare that to the previous syntax Constructor here
andHere. In the previous syntax, we needed to require that we
print "non-arrowed" types for here, and andHere to avoid
something like Constructor a=>b c=>d. In the new syntax, we don't
care if here and andHere have unguarded arrow types like a=>b
because they're safely separated by commas. *)
| Pcstr_tuple l -> [ makeTup (List.map ~f:self#core_type l) ]
in
let gadtRes =
match pcd_res with
| None -> None
| Some x -> Some (formatJustTheTypeConstraint (self#core_type x))
in
let normalize lst =
match lst with
| [] -> raise (NotPossible "should not be called")
| [ hd ] -> hd
| _ :: _ ->
makeList ~inline:(true, true) ~break:IfNeed ~postSpace:true lst
in
let add_bar constructor =
makeList
~postSpace:true
(if print_bar then [ atom "|"; constructor ] else [ constructor ])
in
(* In some cases (e.g. inline records) we want the label with bar & the gadt resolution
* as a list.
* | If {
* pred: expr bool,
* true_branch: expr 'a,
* false_branch: expr 'a
* } ==> end of label
* :expr 'a; ==> gadt res
* The label & the gadt res form two separate units combined into a list.
* This is necessary to properly align the closing '}' on the same height as the 'If'.
*)
let add_bar_2 ?gadt name args =
let lbl = label name args in
let fullLbl =
match gadt with
| Some g -> makeList ~inline:(true, true) ~break:IfNeed [ lbl; g ]
| None -> lbl
in
add_bar fullLbl
in
let prefix = if polymorphic then "`" else "" in
let sourceMappedName =
atom ~loc:pcd_name.loc (prefix ^ pcd_name.txt)
in
let sourceMappedNameWithAttributes =
let layout =
match stdAttrs with
| [] -> sourceMappedName
| stdAttrs ->
formatAttributed sourceMappedName (self#attributes stdAttrs)
in
match docAttrs with
| [] -> layout
| docAttrs ->
makeList
~break:Always
~inline:(true, true)
[ makeList (self#attributes docAttrs); layout ]
in
let constructorName =
makeList ~postSpace:true [ sourceMappedNameWithAttributes ]
in
let everything =
match args, gadtRes with
| [], None -> add_bar sourceMappedNameWithAttributes
| [], Some gadt -> add_bar_2 sourceMappedNameWithAttributes gadt
| _ :: _, None -> add_bar_2 constructorName (normalize args)
| _ :: _, Some gadt ->
(match pcd_args with
| Pcstr_record _ ->
add_bar_2 ~gadt constructorName (normalize args)
| _ -> add_bar_2 constructorName ~gadt (normalize args))
in
source_map ~loc:pcd_loc everything
method record_declaration ?(wrap = "{", "}") ?assumeRecordLoc lbls =
let recordRow pld =
let hasPunning = recordRowIsPunned pld in
let name =
let name = add_raw_identifier_prefix pld.pld_name.txt in
if hasPunning then [ atom name ] else [ atom name; atom ":" ]
in
let name = source_map ~loc:pld.pld_name.loc (makeList name) in
let withMutable =
match pld.pld_mutable with
| Immutable -> name
| Mutable -> makeList ~postSpace:true [ atom "mutable"; name ]
in
let recordRow =
if hasPunning
then label withMutable (atom "")
else label ~space:true withMutable (self#core_type pld.pld_type)
in
let recordRow =
match pld.pld_attributes with
| [] -> recordRow
| attrs ->
let { Reason_attributes.stdAttrs; docAttrs; _ } =
Reason_attributes.partitionAttributes ~partDoc:true attrs
in
let stdAttrsLayout =
makeList
~inline:(true, true)
~postSpace:true
(self#attributes stdAttrs)
in
let docAttrsLayout =
makeList ~inline:(true, true) (self#attributes docAttrs)
in
let children =
match docAttrs, stdAttrs with
| [], [] -> [ recordRow ]
| _, [] -> [ docAttrsLayout; recordRow ]
| [], _ -> [ stdAttrsLayout; recordRow ]
| _, _ -> [ docAttrsLayout; stdAttrsLayout; recordRow ]
in
makeList ~inline:(true, true) ~break:Always_rec children
in
source_map ~loc:pld.pld_loc recordRow
in
let rows = List.map ~f:recordRow lbls in
(* if a record type has more than 1 row, always break *)
let break =
match rows with
| [] | [ _ ] -> Layout.IfNeed
| _ -> Layout.Always_rec
in
source_map
?loc:assumeRecordLoc
(makeList ~wrap ~sep:commaTrail ~postSpace:true ~break rows)
(* Returns the type declaration partitioned into three segments - one
suitable for appending to a label, the actual type manifest and the
list of constraints. *)
method type_declaration_binding_segments x =
(* Segments of the type binding (occuring after the type keyword) that
* should begin with "=". Zero to two total sections.
* This is just a straightforward reverse mapping from the original parser:
* type_kind:
* /*empty*/
* { (Ptype_abstract, Public, None) }
* | EQUAL core_type
* { (Ptype_abstract, Public, Some $2) }
* | EQUAL PRIVATE core_type
* { (Ptype_abstract, Private, Some $3) }
* | EQUAL constructor_declarations
* { (Ptype_variant(List.rev $2), Public, None) }
* | EQUAL PRIVATE constructor_declarations
* { (Ptype_variant(List.rev $3), Private, None) }
* | EQUAL private_flag BAR constructor_declarations
* { (Ptype_variant(List.rev $4), $2, None) }
* | EQUAL DOTDOT
* { (Ptype_open, Public, None) }
* | EQUAL private_flag LBRACE label_declarations opt_comma RBRACE
* { (Ptype_record(List.rev $4), $2, None) }
* | EQUAL core_type EQUAL private_flag opt_bar constructor_declarations
* { (Ptype_variant(List.rev $6), $4, Some $2) }
* | EQUAL core_type EQUAL DOTDOT
* { (Ptype_open, Public, Some $2) }
* | EQUAL core_type EQUAL private_flag LBRACE label_declarations opt_comma RBRACE
* { (Ptype_record(List.rev $6), $4, Some $2) }
*)
let privateAtom = atom "pri" in
let privatize scope lst =
match scope with Public -> lst | Private -> privateAtom :: lst
in
let estimateRecordOpenBracePoint () =
match x.ptype_params with
| [] -> x.ptype_name.loc.loc_end
| _ ->
(fst (List.nth x.ptype_params (List.length x.ptype_params - 1)))
.ptyp_loc
.loc_end
in
let equalInitiatedSegments =
match x.ptype_kind, x.ptype_private, x.ptype_manifest with
(* /*empty*/ {(Ptype_abstract, Public, None)} *)
| Ptype_abstract, Public, None -> []
(* EQUAL core_type {(Ptype_abstract, Public, Some _)} *)
| Ptype_abstract, Public, Some y -> [ [ self#core_type y ] ]
(* EQUAL PRIVATE core_type {(Ptype_abstract, Private, Some $3)} *)
| Ptype_abstract, Private, Some y ->
[ [ privateAtom; self#core_type y ] ]
(* EQUAL constructor_declarations {(Ptype_variant _., Public, None)} *)
(* This case is redundant *)
(* | (Ptype_variant lst, Public, None) -> [ *)
(* [makeSpacedBreakableInlineList (List.map type_variant_leaf lst)] *)
(* ] *)
(* EQUAL PRIVATE constructor_declarations {(Ptype_variant _, Private, None)} *)
| Ptype_variant lst, Private, None ->
[ [ privateAtom
; makeList
~break:IfNeed
~postSpace:true
~inline:(true, true)
(self#type_variant_list lst)
]
]
(* EQUAL private_flag BAR constructor_declarations {(Ptype_variant
_, $2, None)} *)
| Ptype_variant lst, scope, None ->
[ privatize
scope
[ makeList
~break:Always_rec
~postSpace:true
~inline:(true, true)
(self#type_variant_list lst)
]
]
(* EQUAL DOTDOT {(Ptype_open, Public, None)} *)
| Ptype_open, Public, None -> [ [ atom ".." ] ]
| Ptype_open, Private, None -> [ [ privateAtom; atom ".." ] ]
(* Super confusing how record/variants' manifest is not actually the
description of the structure. What's in the manifest in that case
is the *second* EQUALS asignment. *)
(* EQUAL private_flag LBRACE label_declarations opt_comma RBRACE
{(Ptype_record _, $2, None)} *)
| Ptype_record lst, scope, None ->
let assumeRecordLoc =
{ loc_start = estimateRecordOpenBracePoint ()
; loc_end = x.ptype_loc.loc_end
; loc_ghost = false
}
in
[ privatize scope [ self#record_declaration ~assumeRecordLoc lst ]
]
(* And now all of the forms involving *TWO* equals *)
(* Again, super confusing how manifests of variants/records
represent the structure after the second equals. *)
(* ================================================*)
(* EQUAL core_type EQUAL private_flag opt_bar
constructor_declarations { (Ptype_variant _, _, Some _)} *)
| Ptype_variant lst, scope, Some mani ->
[ [ self#core_type mani ]
; (let variant =
makeList
~break:IfNeed
~postSpace:true
~inline:(true, true)
(self#type_variant_list lst)
in
privatize scope [ variant ])
]
(* EQUAL core_type EQUAL DOTDOT {(Ptype_open, Public, Some $2)} *)
| Ptype_open, Public, Some mani ->
[ [ self#core_type mani ]; [ atom ".." ] ]
(* EQUAL core_type EQUAL private_flag LBRACE label_declarations
opt_comma RBRACE {(Ptype_record _, $4, Some $2)} *)
| Ptype_record lst, scope, Some mani ->
let declaration = self#record_declaration lst in
let record =
match scope with
| Public -> [ declaration ]
| Private -> [ label ~space:true privateAtom declaration ]
in
[ [ self#core_type mani ]; record ]
(* Everything else is impossible *)
(* ================================================*)
| _, _, _ ->
raise (NotPossible "Encountered impossible type specification")
in
let makeConstraint (ct1, ct2, _) =
let constraintEq =
makeList
~postSpace:true
[ atom "constraint"; self#core_type ct1; atom "=" ]
in
label ~space:true constraintEq (self#core_type ct2)
in
let constraints = List.map ~f:makeConstraint x.ptype_cstrs in
equalInitiatedSegments, constraints
(* "non-arrowed" means "a type where all arrows are inside at least one
level of parens" * * z => z: not a "non-arrowed" type. * (a, b): a
"non-arrowed" type. * (z=>z): a "non-arrowed" type because the arrows
are guarded by parens. * * A "non arrowed, non simple" type would be
one that is not-arrowed, and also * not "simple". Simple means it is
"clearly one unit" like (a, b), identifier, * "hello", None. *)
method non_arrowed_non_simple_core_type x =
let { Reason_attributes.stdAttrs; _ } =
Reason_attributes.partitionAttributes x.ptyp_attributes
in
if stdAttrs != []
then
formatAttributed
(self#non_arrowed_simple_core_type
{ x with ptyp_attributes = [] })
(self#attributes stdAttrs)
else
match x.ptyp_desc with
(* This significantly differs from the standard OCaml
printer/parser: Type constructors are no longer simple *)
| _ -> self#non_arrowed_simple_core_type x
method type_param_list_element =
function
| { ptyp_attributes = []; ptyp_desc = Ptyp_package (lid, cstrs); _ }
->
self#typ_package ~mod_prefix:true lid cstrs
| t -> self#core_type t
method non_arrowed_simple_core_type x =
let { Reason_attributes.stdAttrs; _ } =
Reason_attributes.partitionAttributes x.ptyp_attributes
in
if stdAttrs != []
then
formatSimpleAttributed
(self#non_arrowed_simple_core_type
{ x with ptyp_attributes = [] })
(self#attributes stdAttrs)
else
let result =
match x.ptyp_desc with
(* LPAREN core_type_comma_list RPAREN %prec below_NEWDOT *)
(* { match $2 with *)
(* | [] -> raise Parse_error *)
(* | one::[] -> one *)
(* | moreThanOne -> mktyp(Ptyp_tuple(List.rev moreThanOne)) } *)
| Ptyp_tuple l ->
makeTup (List.map ~f:self#type_param_list_element l)
| Ptyp_object (l, o) -> self#unparseObject l o
| Ptyp_package (lid, cstrs) ->
self#typ_package ~protect:true ~mod_prefix:true lid cstrs
(* | QUOTE ident *)
(* { mktyp(Ptyp_var $2) } *)
| Ptyp_var s -> ensureSingleTokenSticksToLabel (self#tyvar s)
(* | UNDERSCORE *)
(* { mktyp(Ptyp_any) } *)
| Ptyp_any -> ensureSingleTokenSticksToLabel (atom "_")
(* | type_longident *)
(* { mktyp(Ptyp_constr(mkrhs $1 1, [])) } *)
| Ptyp_constr (li, []) ->
(* [ensureSingleTokenSticksToLabel] loses location information
which is important when you are embedded inside a list and
comments are to be interleaved around you. Therefore, we wrap
the result in the correct [SourceMap]. *)
source_map
~loc:li.loc
(ensureSingleTokenSticksToLabel (self#longident_loc li))
| Ptyp_constr (li, l) ->
(match l with
| [ { ptyp_desc = Ptyp_object ((_ :: _ as l), o); _ } ]
when isJsDotTLongIdent li.txt ->
(* should have one or more rows, Js.t({..}) should print as Js.t({..})
* {..} has a totally different meaning than Js.t({..}) *)
self#unparseObject ~withStringKeys:true l o
| [ { ptyp_desc = Ptyp_object (l, o); _ } ]
when not (isJsDotTLongIdent li.txt) ->
label
(self#longident_loc li)
(self#unparseObject ~wrap:("(", ")") l o)
| [ { ptyp_desc =
Ptyp_constr
( lii
, [ { ptyp_desc = Ptyp_object ((_ :: _ as ll), o); _ }
] )
; _
}
]
when isJsDotTLongIdent lii.txt ->
label
(self#longident_loc li)
(self#unparseObject
~withStringKeys:true
~wrap:("(", ")")
ll
o)
| _ ->
(* small guidance: in `type foo = bar`, we're now at the `bar`
part *)
(* The single identifier has to be wrapped in a
[ensureSingleTokenSticksToLabel] to avoid (@see
@avoidSingleTokenWrapping): *)
label
(self#longident_loc li)
(makeTup (List.map ~f:self#type_param_list_element l)))
| Ptyp_variant (l, closed, low) ->
let pcd_attributes = x.ptyp_attributes in
let pcd_res = None in
let variant_helper i rf =
match rf.prf_desc with
| Rtag (label, opt_ampersand, ctl) ->
let label =
{ label with txt = add_raw_identifier_prefix label.txt }
in
let pcd_args = Pcstr_tuple ctl in
let all_attrs =
List.concat [ pcd_attributes; rf.prf_attributes ]
in
self#type_variant_leaf
~opt_ampersand
~polymorphic:true
{ pcd_name = label
; pcd_args
; pcd_res
; pcd_loc = label.loc
; pcd_attributes = all_attrs
; pcd_vars = []
}
| Rinherit ct ->
(* '| type' is required if the Rinherit is not the first
row_field in the list *)
if i = 0
then self#core_type ct
else
makeList ~postSpace:true [ atom "|"; self#core_type ct ]
in
let designator, tl =
match closed, low with
| Closed, None -> "", []
| Closed, Some tl -> "<", tl
| Open, _ -> ">", []
in
let node_list = List.mapi ~f:variant_helper l in
let ll = List.map ~f:(fun t -> atom ("`" ^ t)) tl in
let tag_list =
makeList ~postSpace:true ~break:IfNeed (atom ">" :: ll)
in
let type_list =
if tl != [] then node_list @ [ tag_list ] else node_list
in
let break =
match type_list with
| _ :: _ :: _ -> Layout.Always_rec
| [] | _ :: [] -> IfNeed
in
makeList
~wrap:("[" ^ designator, "]")
~pad:(true, false)
~postSpace:true
~break
type_list
| Ptyp_class (li, []) ->
makeList [ atom "#"; self#longident_loc li ]
| Ptyp_class (li, l) ->
label
(makeList [ atom "#"; self#longident_loc li ])
(makeTup (List.map ~f:self#core_type l))
| Ptyp_extension e -> self#extension e
| Ptyp_arrow (_, _, _) | Ptyp_alias (_, _) | Ptyp_poly (_, _) ->
makeList ~wrap:("(", ")") ~break:IfNeed [ self#core_type x ]
| Ptyp_open (m, ct) ->
label
(label (self#longident m.txt) (atom "."))
(self#core_type ct)
in
source_map ~loc:x.ptyp_loc result
(* TODO: ensure that we have a form of desugaring that protects *)
(* when final argument of curried pattern is a type constraint: *)
(* | COLON non_arrowed_core_type EQUALGREATER expr { mkexp_constraint $4
(Some $2, None) } *)
(* \----/ \--/
* constraint coerce
*
* Creates a ghost expression:
* mkexp_constraint | Some t, None -> ghexp(Pexp_constraint(e, t))
*)
method pattern_list_split_cons acc =
function
| { ppat_desc =
Ppat_construct
( { txt = Lident "::"; _ }
, Some ([], { ppat_desc = Ppat_tuple [ pat1; pat2 ]; _ }) )
; _
} ->
self#pattern_list_split_cons (pat1 :: acc) pat2
| p -> List.rev acc, p
(* Adds parens to the right sub-tree when it is not a single node: * * A
| B is formatted as A | B * A | (B | C) is formatted as A | (B | C) *
* Also, adds parens to both sub-trees when both of them * are not a
single node: * (A | B) | (C | D) is formatted as A | B | (C | D) * A
| B | (C | D) is formatted as A | B | (C | D) * (A | B) | C is
formatted as A | B | C * A | B | C is formatted as A | B | C * *)
method or_pattern p1 p2 =
let p1_raw, p2_raw = self#pattern p1, self#pattern p2 in
let left, right =
match p2.ppat_desc with
| Ppat_or _ -> p1_raw, formatPrecedence p2_raw
| _ -> p1_raw, p2_raw
in
makeList
~break:IfNeed
~inline:(true, true)
~sep:(Sep "|")
~postSpace:true
~preSpace:true
[ left; right ]
method pattern_with_precedence ?(attrs = []) p =
let raw_pattern = self#pattern p in
match p.ppat_desc, attrs with
| Ppat_or (p1, p2), _ -> formatPrecedence (self#or_pattern p1 p2)
| Ppat_constraint _, _ | _, _ :: _ ->
makeList ~wrap:("(", ")") [ raw_pattern ]
| _, [] -> raw_pattern
(* Renders level 3 or simpler patterns:
*
* Simpler
* ^ -----------
* | 1. [ ], { }, X.{ }, ident, (any-other-pattern-with-parens-around)
* | 2. F(args), lazy(foo), [@attr] 1-2
* | 3. pat as alias, pat | pat
* | 4. 1-3 : typ
* v ------------
* Complex
*
* Assumes visually rendered attributes have already been rendered.
*)
method pattern_at_least_as_simple_as_alias_or_or x =
let { Reason_attributes.arityAttrs = _; stdAttrs; _ } =
Reason_attributes.partitionAttributes x.ppat_attributes
in
match stdAttrs, x.ppat_desc with
| [], Ppat_or (p1, p2) -> self#or_pattern p1 p2
| [], Ppat_alias (p, s) ->
let pattern_with_precedence = self#pattern_with_precedence p in
label
~space:true
(source_map ~loc:p.ppat_loc pattern_with_precedence)
(makeList
~postSpace:true
[ atom "as"; source_map ~loc:s.loc (protectIdentifier s.txt) ])
(* RA*)
| _ -> self#pattern_at_least_as_simple_as_application x
(* Formats a pattern that is a least as "simple" as function application
* style syntax. Produces formatting that is as simple as either 1 or 2.
*
* Simpler
* ^ -----------
* | 1. [ ], { }, X.{ }, ident, (any-other-pattern-with-parens-around)
* | 2. F(args), lazy(foo), [@attr] 1-2
* | 3. pat as alias, pat | pat
* | 4. 1-3 : typ
* v ------------
* Complex
*
*
* 1. and 2. do not need parens around them in order to apply attributes to
* them. 3. does need parens around it to apply attributes to the whole
* pattern.
*
* Assumes visually rendered attributes have already been rendered.
*)
method pattern_at_least_as_simple_as_application x =
(* TODOATTRIBUTES: Handle the stdAttrs here *)
let { Reason_attributes.stdAttrs; arityAttrs; _ } =
Reason_attributes.partitionAttributes x.ppat_attributes
in
let formattedPattern =
match x.ppat_desc with
| Ppat_variant (l, Some p) ->
if arityAttrs != []
then
raise
(NotPossible
"Should never see embedded attributes on poly variant")
else
source_map
~loc:x.ppat_loc
(self#constructor_pattern
(atom ("`" ^ l))
p
~polyVariant:true
~arityIsClear:true)
| Ppat_lazy p ->
label (atom "lazy") (formatPrecedence (self#simple_pattern p))
| Ppat_construct
({ txt = Lident (("true" | "false") as txt); _ }, None) ->
atom txt
| Ppat_construct (({ txt; _ } as li), po)
when not (txt = Lident "::") ->
(* FIXME The third field always false *)
let formattedConstruction =
match po with
(* TODO: Check the explicit_arity field on the
pattern/constructor attributes to determine if should desugar
to an *actual* tuple. *)
(* | Some ({ *)
(* ppat_desc=Ppat_tuple l; *)
(* ppat_attributes=[{txt="explicit_arity"; loc}] *)
(* }) -> *)
(* label ~space:true (self#longident_loc li)
(makeSpacedBreakableInlineList (List.map self#simple_pattern
l)) *)
| Some (_, pattern) ->
let arityIsClear = isArityClear arityAttrs in
self#constructor_pattern
~arityIsClear
(self#longident_loc li)
pattern
| None -> self#longident_loc li
in
source_map ~loc:x.ppat_loc formattedConstruction
| _ -> self#simple_pattern { x with ppat_attributes = arityAttrs }
in
if stdAttrs != []
then formatAttributed formattedPattern (self#attributes stdAttrs)
else formattedPattern
(* Format a pattern with no particular requirements of simplicity. For example when
* formatting a pattern *inside* one tuple position:
* |
* v
* let (x : int, foo) = ..
*
*
* Renders level 3 or simpler patterns:
*
* Simpler
* ^ -----------
* | 1. [ ], { }, X.{ }, ident, (any-other-pattern-with-parens-around)
* | 2. F(args), lazy(foo), [@attr] 1-2
* | 3. pat as alias, pat | pat
* | 4. 1-3 : typ
* v ------------
* Complex
*
* Assumes visually rendered attributes have already been rendered.
*)
method pattern x =
let { Reason_attributes.arityAttrs = _; stdAttrs; _ } =
Reason_attributes.partitionAttributes x.ppat_attributes
in
match stdAttrs, x.ppat_desc with
| [], Ppat_constraint (p, ct) ->
let pat, typ =
match p, ct with
| ( { ppat_desc = Ppat_unpack unpack; _ }
, { ptyp_desc = Ptyp_package (lid, cstrs); _ } ) ->
let unpack =
match unpack.txt with None -> "_" | Some unpack -> unpack
in
( makeList ~postSpace:true [ atom "module"; atom unpack ]
, self#typ_package ~mod_prefix:false lid cstrs )
| _ ->
(* Have to call pattern_at_least_as_simple_as_alias_or_or
because * we don't want to allow *another* nested type
annotation without * first adding parens *)
( self#pattern_at_least_as_simple_as_alias_or_or p
, self#core_type ct )
in
formatTypeConstraint pat typ
| _ -> self#pattern_at_least_as_simple_as_alias_or_or x
method patternList ?(wrap = "", "") pat =
let pat_list, pat_last = self#pattern_list_split_cons [] pat in
let pat_list = List.map ~f:self#pattern pat_list in
match pat_last with
| { ppat_desc = Ppat_construct ({ txt = Lident "[]"; _ }, _); _ } ->
(* [x,y,z] *)
let lwrap, rwrap = wrap in
makeList
pat_list
~break:Layout.IfNeed
~sep:commaTrail
~postSpace:true
~wrap:(lwrap ^ "[", "]" ^ rwrap)
| _ ->
(* x::y *)
makeES6List pat_list (self#pattern pat_last) ~wrap
(* In some contexts the Ptyp_package needs to be protected by parens, or
* the `module` keyword needs to be added. * Example: let f = (module
Add: S.Z, x) => Add.add(x); * It's clear that `S.Z` is a module
because it constraints the * `module Add` pattern. No need to add
"module" before `S.Z`. * * Example2: * type t = (module Console); *
In this case the "module" keyword needs to be printed to indicate *
usage of a first-class-module. *)
method typ_package ?(protect = false) ?(mod_prefix = true) lid cstrs =
let packageIdent =
let packageIdent = self#longident_loc lid in
if mod_prefix
then makeList ~postSpace:true [ atom "module"; packageIdent ]
else packageIdent
in
let unwrapped_layout =
match cstrs with
| [] -> packageIdent
| cstrs ->
label
~space:true
(makeList ~postSpace:true [ packageIdent; atom "with" ])
(makeList
~inline:(true, true)
~break:IfNeed
~sep:(Sep " and ")
(List.map
~f:(fun (s, ct) ->
label
~space:true
(makeList
~break:IfNeed
~postSpace:true
[ atom "type"; self#longident_loc s; atom "=" ])
(self#core_type ct))
cstrs))
in
if protect
then makeList ~postSpace:true ~wrap:("(", ")") [ unwrapped_layout ]
else unwrapped_layout
method simple_pattern x =
let { Reason_attributes.arityAttrs; stdAttrs; _ } =
Reason_attributes.partitionAttributes x.ppat_attributes
in
if stdAttrs != []
then
formatSimpleAttributed
(self#simple_pattern { x with ppat_attributes = arityAttrs })
(self#attributes stdAttrs)
else
let itm =
match x.ppat_desc with
| Ppat_construct
( { loc; txt = Lident (("()" | "[]" | "true" | "false") as x) }
, _ ) ->
(* Patterns' locations might include a leading bar depending on
the * context it was parsed in. Therefore, we need to include
further * information about the contents of the pattern such
as tokens etc, * in order to get comments to be distributed
correctly.*)
atom ~loc x
| Ppat_construct ({ txt = Lident "::"; _ }, _) ->
self#patternList x (* LIST PATTERN *)
| Ppat_construct (li, None) ->
source_map ~loc:x.ppat_loc (self#longident_loc li)
| Ppat_any -> atom "_"
| Ppat_var { loc; txt } ->
(* To prevent this: * * let oneArgShouldWrapToAlignWith *
theFunctionNameBinding => theFunctionNameBinding; * * And
instead do: * * let oneArgShouldWrapToAlignWith *
theFunctionNameBinding => theFunctionNameBinding; * * We have
to do something to the non "listy" patterns. Non listy *
patterns don't indent the same amount as listy patterns when
docked * to a label. * * If wrapping the non-listy pattern in
[ensureSingleTokenSticksToLabel] * you'll get the following
(even though it should wrap) * * let
oneArgShouldWrapToAlignWith theFunctionNameBinding =>
theFunctionNameBinding; *)
source_map ~loc (protectIdentifier txt)
| Ppat_array l -> self#patternArray l
| Ppat_unpack s ->
let s = match s.txt with None -> "_" | Some s -> s in
makeList
~wrap:("(", ")")
~break:IfNeed
~postSpace:true
[ atom "module"; atom s ]
| Ppat_open (lid, pat) ->
(* let someFn Qualified.{ record } = ... *)
let needsParens =
match pat.ppat_desc with
| Ppat_exception _ -> true
| _ -> false
in
let pat = self#simple_pattern pat in
label
(label (self#longident_loc lid) (atom "."))
(if needsParens then formatPrecedence pat else pat)
| Ppat_type li -> makeList [ atom "#"; self#longident_loc li ]
| Ppat_record (l, closed) -> self#patternRecord l closed
| Ppat_tuple l -> self#patternTuple l
| Ppat_constant c ->
let raw_literal, _ =
Reason_attributes.extract_raw_literal x.ppat_attributes
in
self#constant ?raw_literal c
| Ppat_interval (c1, c2) ->
makeList
~postSpace:true
[ self#constant c1; atom ".."; self#constant c2 ]
| Ppat_variant (l, None) -> makeList [ atom "`"; atom l ]
| Ppat_constraint _ -> formatPrecedence (self#pattern x)
| Ppat_lazy p ->
formatPrecedence
(label
(atom "lazy")
(formatPrecedence (self#simple_pattern p)))
| Ppat_extension e -> self#extension e
| Ppat_exception p ->
(* An exception pattern with an alias should be wrapped in (...)
* The rules for what goes to the right of the exception are a
little (too) nuanced. * It accepts "non simple" parameters,
except in the case of `as`. * Here we consistently apply
"simplification" to the exception argument. * Example: * |
exception (Sys_error _ as exc) => raise exc * parses
correctly while * | Sys_error _ as exc => raise exc * results
in incorrect parsing with type error otherwise. *)
makeList
~postSpace:true
[ atom "exception"; self#simple_pattern p ]
| _ -> formatPrecedence (self#pattern x)
(* May have a redundant sourcemap *)
in
source_map ~loc:x.ppat_loc itm
method label_exp lbl opt pat =
let term = self#pattern pat in
let param =
match lbl with
| Nolabel -> term
| (Labelled lbl | Optional lbl)
when is_punned_labelled_pattern_no_attrs pat lbl ->
makeList [ atom namedArgSym; term ]
| Labelled lbl | Optional lbl ->
let lblLayout =
makeList
~sep:(Sep " ")
~break:Layout.Never
[ atom (namedArgSym ^ lbl); atom "as" ]
in
label lblLayout ~space:true term
in
match opt, lbl with
| None, Optional _ -> makeList [ param; atom "=?" ]
| None, _ -> param
| Some o, _ ->
makeList
[ param; atom "="; self#unparseProtectedExpr ~forceParens:true o ]
method access op cls e1 e2 =
makeList
[ (* Important that this be not breaking - at least to preserve same
behavior as stock desugarer. It might even be required (double
check in parser.mly) *)
e1
; atom op
; e2
; atom cls
]
method simple_get_application x =
let { Reason_attributes.stdAttrs; jsxAttrs; _ } =
Reason_attributes.partitionAttributes x.pexp_attributes
in
match x.pexp_desc, stdAttrs, jsxAttrs with
| _, _ :: _, [] -> None (* Has some printed attributes - not simple *)
| Pexp_apply ({ pexp_desc = Pexp_ident loc; _ }, l), [], _jsx :: _ ->
(* TODO: Soon, we will allow the final argument to be an identifier
which represents the entire list. This would be written as
`<tag>...list</tag>`. If you imagine there being an implicit []
inside the tag, then it would be consistent with array spread:
[...list] evaluates to the thing as list. *)
let hasLabelledChildrenLiteral =
List.exists
~f:(function Labelled "children", _ -> true | _ -> false)
l
in
let rec hasSingleNonLabelledUnitAndIsAtTheEnd l =
match l with
| [] -> false
| ( Nolabel
, { pexp_desc = Pexp_construct ({ txt = Lident "()"; _ }, _)
; _
} )
:: [] ->
true
| (Nolabel, _) :: _ -> false
| _ :: rest -> hasSingleNonLabelledUnitAndIsAtTheEnd rest
in
if
hasLabelledChildrenLiteral
&& hasSingleNonLabelledUnitAndIsAtTheEnd l
then
match loc.txt with
| Ldot (moduleLid, "createElement") ->
Some
(self#formatJSXComponent
(String.concat ~sep:"." (Longident.flatten_exn moduleLid))
l)
| lid ->
Some
(self#formatJSXComponent
(String.concat ~sep:"." (Longident.flatten_exn lid))
l)
else None
| ( Pexp_apply
( { pexp_desc =
Pexp_letmodule
( _
, ({ pmod_desc = Pmod_apply _; _ } as app)
, { pexp_desc = Pexp_ident loc; _ } )
; _
}
, l )
, []
, _jsx :: _ ) ->
(* TODO: Soon, we will allow the final argument to be an identifier
which represents the entire list. This would be written as
`<tag>...list</tag>`. If you imagine there being an implicit []
inside the tag, then it would be consistent with array spread:
[...list] evaluates to the thing as list. *)
let rec extract_apps args = function
| { pmod_desc = Pmod_apply (m1, { pmod_desc = Pmod_ident loc; _ })
; _
} ->
let arg =
String.concat ~sep:"." (Longident.flatten_exn loc.txt)
in
extract_apps (arg :: args) m1
| { pmod_desc = Pmod_ident loc; _ } ->
String.concat ~sep:"." (Longident.flatten_exn loc.txt) :: args
| _ ->
failwith
"Functors in JSX tags support only module names as parameters"
in
let hasLabelledChildrenLiteral =
List.exists
~f:(function Labelled "children", _ -> true | _ -> false)
l
in
let rec hasSingleNonLabelledUnitAndIsAtTheEnd l =
match l with
| [] -> false
| ( Nolabel
, { pexp_desc = Pexp_construct ({ txt = Lident "()"; _ }, _)
; _
} )
:: [] ->
true
| (Nolabel, _) :: _ -> false
| _ :: rest -> hasSingleNonLabelledUnitAndIsAtTheEnd rest
in
if
hasLabelledChildrenLiteral
&& hasSingleNonLabelledUnitAndIsAtTheEnd l
then
match Longident.flatten_exn loc.txt with
| [] | [ _ ] ->
Some (self#formatJSXComponent (Longident.last_exn loc.txt) l)
| _ ->
if Longident.last_exn loc.txt = "createElement"
then
match extract_apps [] app with
| ftor :: args ->
let applied =
ftor ^ "(" ^ String.concat ~sep:", " args ^ ")"
in
Some
(self#formatJSXComponent
~closeComponentName:ftor
applied
l)
| _ -> None
else None
else None
| _ -> None
method sugar_set_expr_parts e =
if e.pexp_attributes != []
then None (* should also check attributes underneath *)
else
match e.pexp_desc with
| Pexp_apply
( { pexp_desc =
Pexp_ident { txt = Ldot (Lident "Array", "set"); _ }
; _
}
, [ (_, e1); (_, e2); (_, e3) ] ) ->
let prec = Custom "prec_lbracket" in
let lhs =
self#unparseResolvedRule
(self#ensureExpression ~reducesOnToken:prec e1)
in
Some (self#access "[" "]" lhs (self#unparseExpr e2), e3)
| Pexp_apply
( { pexp_desc =
Pexp_ident { txt = Ldot (Lident "String", "set"); _ }
; _
}
, [ (_, e1); (_, e2); (_, e3) ] ) ->
let prec = Custom "prec_lbracket" in
let lhs =
self#unparseResolvedRule
(self#ensureExpression ~reducesOnToken:prec e1)
in
Some (self#access ".[" "]" lhs (self#unparseExpr e2), e3)
| Pexp_apply
( { pexp_desc =
Pexp_ident
{ txt = Ldot (Ldot (Lident "Bigarray", array), "set")
; _
}
; _
}
, label_exprs ) ->
(match array with
| "Genarray" ->
(match label_exprs with
| [ (_, a); (_, { pexp_desc = Pexp_array ls; _ }); (_, c) ] ->
let formattedList = List.map ~f:self#unparseExpr ls in
let lhs =
makeList
[ self#simple_enough_to_be_lhs_dot_send a; atom "." ]
in
let rhs =
makeList
~break:IfNeed
~postSpace:true
~sep:commaSep
~wrap:("{", "}")
formattedList
in
Some (label lhs rhs, c)
| _ -> None)
| "Array1" | "Array2" | "Array3" ->
(match label_exprs with
| (_, a) :: rest ->
(match List.rev rest with
| (_, v) :: rest ->
let args = List.map ~f:snd (List.rev rest) in
let formattedList = List.map ~f:self#unparseExpr args in
let lhs =
makeList
[ self#simple_enough_to_be_lhs_dot_send a; atom "." ]
in
let rhs =
makeList
~break:IfNeed
~postSpace:true
~sep:commaSep
~wrap:("{", "}")
formattedList
in
Some (label lhs rhs, v)
| _ -> assert false)
| _ -> assert false)
| _ -> None)
| _ -> None
(** Detects "sugar expressions" (sugar for array/string setters) and
returns their separate parts. *)
(* How would we know not to print the sequence without { }; protecting the let a?
*
* let a
* |
* sequence
* / \
* let a print a
* alert a
* let res = {
* let a = something();
* { \
* alert(a); | portion to be parsed as a sequence()
* let a = 20; | The final ; print(a) causes the entire
* alert(a); | portion to be parsed as a sequence()
* }; |
* print (a); /
* }
*
* ******************************************************************
* Any time the First expression of a sequence is another sequence, or (as in
* this case) a let, wrapping the first sequence expression in { } is
* required.
* ******************************************************************
*)
(** TODO: Configure the optional ability to print the *minimum* number
of parens. It's simply a matter of changing [higherPrecedenceThan]
to [higherOrEqualPrecedenceThan]. *)
(* The point of the function is to ensure that
~reducesAfterRight:rightExpr will reduce at the proper time when it
is reparsed, possibly wrapping it in parenthesis if needed. It
ensures a rule doesn't reduce until *after* `reducesAfterRight` gets
a chance to reduce. Example: The addition rule which has precedence
of rightmost token "+", in `x + a * b` should not reduce until after
the a * b gets a chance to reduce. This function would determine the
minimum parens to ensure that. *)
method ensureContainingRule ~withPrecedence ~reducesAfterRight () =
match self#unparseExprRecurse reducesAfterRight with
| SpecificInfixPrecedence ({ shiftPrecedence; _ }, rightRecurse) ->
if higherPrecedenceThan shiftPrecedence withPrecedence
then rightRecurse
else if higherPrecedenceThan withPrecedence shiftPrecedence
then
LayoutNode
(formatPrecedence
~loc:reducesAfterRight.pexp_loc
(self#unparseResolvedRule rightRecurse))
else if isRightAssociative ~prec:withPrecedence
then rightRecurse
else
LayoutNode
(formatPrecedence
~loc:reducesAfterRight.pexp_loc
(self#unparseResolvedRule rightRecurse))
| FunctionApplication itms ->
let funApplExpr =
formatAttachmentApplication
applicationFinalWrapping
None
(itms, Some reducesAfterRight.pexp_loc)
in
(* Little hack: need to print parens for the `bar` application in
e.g. `foo->other##(bar(baz))` or `foo->other->(bar(baz))`. *)
if higherPrecedenceThan withPrecedence (Custom "prec_functionAppl")
then
LayoutNode
(formatPrecedence ~loc:reducesAfterRight.pexp_loc funApplExpr)
else LayoutNode funApplExpr
| PotentiallyLowPrecedence itm ->
LayoutNode (formatPrecedence ~loc:reducesAfterRight.pexp_loc itm)
| Simple itm -> LayoutNode itm
method ensureExpression ~reducesOnToken expr =
match self#unparseExprRecurse expr with
| SpecificInfixPrecedence ({ reducePrecedence; _ }, leftRecurse) ->
if higherPrecedenceThan reducePrecedence reducesOnToken
then leftRecurse
else if higherPrecedenceThan reducesOnToken reducePrecedence
then
LayoutNode
(formatPrecedence
~loc:expr.pexp_loc
(self#unparseResolvedRule leftRecurse))
else if isLeftAssociative ~prec:reducesOnToken
then leftRecurse
else
LayoutNode
(formatPrecedence
~loc:expr.pexp_loc
(self#unparseResolvedRule leftRecurse))
| FunctionApplication itms ->
LayoutNode
(formatAttachmentApplication
applicationFinalWrapping
None
(itms, Some expr.pexp_loc))
| PotentiallyLowPrecedence itm ->
LayoutNode (formatPrecedence ~loc:expr.pexp_loc itm)
| Simple itm -> LayoutNode itm
method unparseExpr x =
match self#unparseExprRecurse x with
| SpecificInfixPrecedence (_, resolvedRule) ->
self#unparseResolvedRule resolvedRule
| FunctionApplication itms ->
formatAttachmentApplication
applicationFinalWrapping
None
(itms, Some x.pexp_loc)
| PotentiallyLowPrecedence itm -> itm
| Simple itm -> itm
(** Attempts to unparse: The beginning of a more general printing
algorithm, that determines how to print based on precedence of
tokens and rules. The end goal is that this should be completely
auto-generated from the Menhir parsing tables. We could move more
and more into this function.
You could always just call self#expression, but `unparseExpr` will
render infix/prefix/unary/terary fixities in their beautiful forms
while minimizing parenthesis. *)
(* This method may not even be needed *)
method unparseUnattributedExpr x =
match Reason_attributes.partitionAttributes x.pexp_attributes with
| { docAttrs = []; stdAttrs = []; _ } -> self#unparseExpr x
| _ -> makeList ~wrap:("(", ")") [ self#unparseExpr x ]
(* ensureExpr ensures that the expression is wrapped in parens * e.g. is
necessary in cases like: * let display = (:message=("hello": string))
=> 1; * but not in cases like: * let f = (a: bool) => 1; * TODO: in
the future we should probably use the type ruleCategory * to
'automatically' ensure the validity of a constraint expr with
parens... *)
method unparseProtectedExpr ?(forceParens = false) e =
let itm =
match e with
| { pexp_attributes = []; pexp_desc = Pexp_constraint (x, ct); _ }
->
let x = self#unparseExpr x in
let children =
[ x; label ~space:true (atom ":") (self#core_type ct) ]
in
if forceParens
then makeList ~wrap:("(", ")") children
else makeList children
| { pexp_attributes; pexp_desc = Pexp_constant c; _ } ->
(* When we have Some(-1) or someFunction(-1, -2), the arguments -1
and -2 * pass through this case. In this context they don't
need to be wrapped in extra parens * Some((-1)) should be
printed as Some(-1). This is in contrast with * 1 + (-1) where
we print the parens for readability. *)
let raw_literal, pexp_attributes =
Reason_attributes.extract_raw_literal pexp_attributes
in
let constant = self#constant ?raw_literal ~parens:forceParens c in
(match pexp_attributes with
| [] -> constant
| attrs ->
let formattedAttrs =
makeSpacedBreakableInlineList
(List.map ~f:self#item_attribute attrs)
in
makeSpacedBreakableInlineList [ formattedAttrs; constant ])
| { pexp_desc = Pexp_function (_ :: _, _, Pfunction_body _); _ } ->
self#formatPexpFun e
| x -> self#unparseExpr x
in
source_map ~loc:e.pexp_loc itm
method simplifyUnparseExpr
?(inline = false)
?(even_wrap_simple = false)
?(wrap = "(", ")")
x =
match self#unparseExprRecurse x, even_wrap_simple with
| SpecificInfixPrecedence (_, itm), _ ->
formatPrecedence
~inline
~wrap
~loc:x.pexp_loc
(self#unparseResolvedRule itm)
| FunctionApplication itms, _ ->
formatPrecedence
~inline
~wrap
~loc:x.pexp_loc
(formatAttachmentApplication
applicationFinalWrapping
None
(itms, Some x.pexp_loc))
| PotentiallyLowPrecedence itm, _ | Simple itm, true ->
formatPrecedence ~inline ~wrap ~loc:x.pexp_loc itm
| Simple itm, false -> itm
method unparseResolvedRule =
function
| LayoutNode layoutNode -> layoutNode
| InfixTree _ as infixTree ->
formatComputedInfixChain (computeInfixChain infixTree)
method unparseExprApplicationItems x =
match self#unparseExprRecurse x with
| SpecificInfixPrecedence (_, wrappedRule) ->
let itm = self#unparseResolvedRule wrappedRule in
[ itm ], Some x.pexp_loc
| FunctionApplication itms -> itms, Some x.pexp_loc
| PotentiallyLowPrecedence itm -> [ itm ], Some x.pexp_loc
| Simple itm -> [ itm ], Some x.pexp_loc
(* Provides beautiful printing for pipe first sugar: * foo * ->f(a, b) *
->g(c, d) *)
method formatPipeFirst e =
let module PipeFirstTree = struct
type exp = Parsetree.expression
type flatNode =
| Exp of exp
| ExpU of exp (* uncurried *)
| Args of (Asttypes.arg_label * exp) list
type flatT = flatNode list
type node =
{ exp : exp
; args : (Asttypes.arg_label * exp) list
; uncurried : bool
}
type t = node list
let formatNode ?prefix ?(first = false) { exp; args; uncurried } =
let formatLayout expr =
let formatted =
if first
then
self#ensureExpression
~reducesOnToken:(Token pipeFirstToken)
expr
else
match expr with
(* a->foo(x, _) and a->(foo(x, _)) are equivalent under pipe
first * (a->foo)(x, _) is unnatural and desugars to *
(__x) => (a |. foo)(x, __x) * Under `->`, it makes more
sense to desugar into * a |. (__x => foo(x, __x)) * *
Hence we don't need parens in this case. *)
| expr when Reason_heuristics.isUnderscoreApplication expr
->
LayoutNode (self#unparseExpr expr)
| _ ->
self#ensureContainingRule
~withPrecedence:(Token pipeFirstToken)
~reducesAfterRight:expr
()
in
self#unparseResolvedRule formatted
in
let parens =
match exp.pexp_desc with
| Pexp_apply (e, _) ->
printedStringAndFixityExpr e = UnaryPostfix "^"
| _ -> false
in
let layout =
match args with
| [] ->
let e = formatLayout exp in
(match prefix with Some l -> makeList [ l; e ] | None -> e)
| args ->
let args =
List.map
~f:(fun (label, arg) ->
label, self#process_underscore_application arg)
args
in
let fakeApplExp =
let loc_end =
match List.rev args with
| (_, e) :: _ -> e.pexp_loc.loc_end
| _ -> exp.pexp_loc.loc_end
in
{ exp with pexp_loc = { exp.pexp_loc with loc_end } }
in
makeList
(self#formatFunAppl
?prefix
~jsxAttrs:[]
~args
~funExpr:exp
~applicationExpr:fakeApplExp
~uncurried
())
in
if parens then formatPrecedence layout else layout
end
in
(* Imagine: foo->f(a, b)->g(c,d) * The corresponding parsetree looks
more like: * (((foo->f)(a,b))->g)(c, d) * The extra Pexp_apply
nodes, e.g. (foo->f), result into a * nested/recursive ast which is
pretty inconvenient in terms of printing. * For printing purposes
we actually want something more like: * foo->|f(a,b)|->|g(c, d)| *
in order to provide to following printing: * foo * ->f(a, b) *
->g(c, d) * The job of "flatten" is to turn the inconvenient,
nested ast * (((foo->f)(a,b))->g)(c, d) * into * [Exp foo; Exp f;
Args [a; b]; Exp g; Args [c; d]] * which can be processed for
printing purposes. *)
let rec flatten ?(uncurried = false) acc = function
| { pexp_desc =
Pexp_apply
( { pexp_desc = Pexp_ident { txt = Longident.Lident "|."; _ }
; _
}
, [ (Nolabel, arg1); (Nolabel, arg2) ] )
; _
} ->
flatten (PipeFirstTree.Exp arg2 :: acc) arg1
| { pexp_attributes
; pexp_desc =
Pexp_apply
( { pexp_desc =
Pexp_apply
( { pexp_desc =
Pexp_ident { txt = Longident.Lident "|."; _ }
; _
}
, [ (Nolabel, arg1); (Nolabel, arg2) ] )
; _
}
, args )
; _
} as e ->
let args = PipeFirstTree.Args args in
(match pexp_attributes with
| [ { attr_name = { txt = "u" | "bs"; _ }
; attr_payload = PStr []
; _
}
] ->
flatten (PipeFirstTree.ExpU arg2 :: args :: acc) arg1
| [] ->
(* the uncurried attribute might sit on the Pstr_eval *
enclosing the Pexp_apply*)
if uncurried
then flatten (PipeFirstTree.ExpU arg2 :: args :: acc) arg1
else flatten (PipeFirstTree.Exp arg2 :: args :: acc) arg1
| _ -> PipeFirstTree.Exp e :: acc)
| { pexp_desc = Pexp_ident { txt = Longident.Lident "|."; _ }; _ }
->
acc
| arg -> PipeFirstTree.Exp arg :: acc
in
(* Given: foo->f(a, b)->g(c, d) * We get the following
PipeFirstTree.flatNode list: * [Exp foo; Exp f; Args [a; b]; Exp g;
Args [c; d]] * The job of `parse` is to turn the "flat
representation" * (a.k.a. PipeFirstTree.flastNode list) into a more
convenient structure * that allows us to express the segments:
"foo" "f(a, b)" "g(c, d)". * PipeFirstTree.t expresses those
segments. * [{exp = foo; args = []}; {exp = f; args = [a; b]}; {exp
= g; args = [c; d]}] *)
let rec parse acc = function
| PipeFirstTree.Exp e :: PipeFirstTree.Args args :: xs ->
parse
(PipeFirstTree.{ exp = e; args; uncurried = false } :: acc)
xs
| PipeFirstTree.ExpU e :: PipeFirstTree.Args args :: xs ->
parse
(PipeFirstTree.{ exp = e; args; uncurried = true } :: acc)
xs
| PipeFirstTree.Exp e :: xs ->
parse
(PipeFirstTree.{ exp = e; args = []; uncurried = false } :: acc)
xs
| _ -> List.rev acc
in
(* Given: foo->f(. a,b); * The uncurried attribute doesn't sit on the
Pexp_apply, but sits on * the top level Pstr_eval. We don't have
access to top-level context here, * hence the lookup in the global
uncurriedTable to correctly determine * if we need to print
uncurried. *)
let uncurried =
try Hashtbl.find uncurriedTable e.pexp_loc with Not_found -> false
in
(* Turn * foo->f(a, b)->g(c, d) * into * [Exp foo; Exp f; Args [a; b];
Exp g; Args [c; d]] *)
let (flatNodes : PipeFirstTree.flatT) = flatten ~uncurried [] e in
(* Turn * [Exp foo; Exp f; Args [a; b]; Exp g; Args [c; d]] * into *
[{exp = foo; args = []}; {exp = f; args = [a; b]}; {exp = g; args =
[c; d]}] *)
let (pipetree : PipeFirstTree.t) = parse [] flatNodes in
(* Turn * [{exp = foo; args = []}; {exp = f; args = [a; b]}; {exp = g;
args = [c; d]}] * into * [foo; ->f(a, b); ->g(c, d)] *)
let pipeSegments =
match pipetree with
(* Special case printing of * foo->bar( * aa, * bb, * ) * * We don't
want * foo * ->bar( * aa, * bb * ) * * Notice how `foo->bar`
shouldn't break, it wastes space and is * inconsistent with *
foo.bar( * aa, * bb, * ) *)
| [ ({ exp = { pexp_desc = Pexp_ident _; _ }; _ } as hd); last ] ->
let prefix =
Some
(makeList
[ PipeFirstTree.formatNode ~first:true hd; atom "->" ])
in
[ PipeFirstTree.formatNode ?prefix last ]
| hd :: tl ->
let hd = PipeFirstTree.formatNode ~first:true hd in
let tl =
List.map
~f:(fun node ->
makeList [ atom "->"; PipeFirstTree.formatNode node ])
tl
in
hd :: tl
| [] -> []
in
(* Provide nice breaking for: [foo; ->f(a, b); ->g(c, d)] * foo *
->f(a, b) * ->g(c, d) *)
makeList ~break:IfNeed ~inline:(true, true) pipeSegments
(*
* Replace (__x) => foo(__x) with foo(_)
*)
method process_underscore_application x =
let process_application expr =
let process_arg (l, e) =
match e.pexp_desc with
| Pexp_ident ({ txt = Lident "__x"; _ } as id) ->
let pexp_desc = Pexp_ident { id with txt = Lident "_" } in
l, { e with pexp_desc }
| _ -> l, e
in
match expr.pexp_desc with
| Pexp_apply (e_fun, args) ->
let pexp_desc =
Pexp_apply (e_fun, List.map ~f:process_arg args)
in
{ expr with pexp_desc }
| _ -> expr
in
match x.pexp_desc with
| Pexp_function
( [ { pparam_desc =
Pparam_val
( Nolabel
, None
, { ppat_desc = Ppat_var { txt = "__x"; _ }; _ } )
; _
}
]
, _
, Pfunction_body ({ pexp_desc = Pexp_apply _; _ } as e) ) ->
process_application e
| Pexp_function (params, constraint_, body) ->
(match body with
| Pfunction_cases _ -> x
| Pfunction_body body ->
let e_processed = self#process_underscore_application body in
if body == e_processed
then x
else
{ x with
pexp_desc =
Pexp_function
(params, constraint_, Pfunction_body e_processed)
})
| _ -> x
method unparseExprRecurse x =
let x = self#process_underscore_application x in
(* If there are any attributes, render unary like `(~-) x [@ppx]`, and
infix like `(+) x y [@attr]` *)
let { Reason_attributes.arityAttrs
; stdAttrs
; jsxAttrs
; stylisticAttrs
; uncurried
; _
}
=
Reason_attributes.partitionAttributes
~allowUncurry:(Reason_heuristics.melExprCanBeUncurried x)
x.pexp_attributes
in
let stylisticAttrs =
Reason_attributes.maybe_remove_stylistic_attrs
stylisticAttrs
~should_preserve:preserve_braces
in
let () =
if uncurried then Hashtbl.add uncurriedTable x.pexp_loc true
in
let x =
{ x with
pexp_attributes =
stylisticAttrs @ arityAttrs @ stdAttrs @ jsxAttrs
}
in
(* If there's any attributes, recurse without them, then apply them to
the ends of functions, or simplify infix printings then append. *)
match stdAttrs, x.pexp_desc with
| _, Pexp_letop _ ->
(* `Pexp_letop` is a bit different than `let` bindings because the
attributes are in `Pexp_letop` rather than the `value_binding`
type (check https://github.com/ocaml/ocaml/issues/9301 too), so
we must treat it a bit differently if we want to print the
attributes inside the braces. *)
FunctionApplication [ makeLetSequence (self#letList x) ]
| _ :: _, _ ->
let withoutVisibleAttrs =
{ x with
pexp_attributes = stylisticAttrs @ arityAttrs @ jsxAttrs
}
in
let attributesAsList = List.map ~f:self#attribute stdAttrs in
let itms =
match self#unparseExprRecurse withoutVisibleAttrs with
| SpecificInfixPrecedence ({ reducePrecedence; _ }, wrappedRule)
->
let itm = self#unparseResolvedRule wrappedRule in
(match reducePrecedence with
(* doesn't need wrapping; we know how to parse *)
| Custom "prec_lbracket" | Token "." -> [ itm ]
| _ -> [ formatPrecedence ~loc:x.pexp_loc itm ])
| FunctionApplication itms -> itms
| PotentiallyLowPrecedence itm ->
[ formatPrecedence ~loc:x.pexp_loc itm ]
| Simple itm -> [ itm ]
in
FunctionApplication
[ makeList
~break:IfNeed
~inline:(true, true)
~indent:0
~postSpace:true
(List.concat [ attributesAsList; itms ])
]
| [], _ ->
(match self#simplest_expression x with
| Some se -> Simple se
| None ->
let self = self#reset_request_braces in
(match x.pexp_desc with
| Pexp_apply (e, ls) ->
let ls =
List.map
~f:(fun (l, expr) ->
l, self#process_underscore_application expr)
ls
in
(match e, ls with
| e, _ when Reason_heuristics.isPipeFirst e ->
let prec = Token pipeFirstToken in
SpecificInfixPrecedence
( { reducePrecedence = prec; shiftPrecedence = prec }
, LayoutNode (self#formatPipeFirst x) )
| ( { pexp_desc =
Pexp_ident { txt = Ldot (Lident "Array", "get"); _ }
; _
}
, [ (_, e1); (_, e2) ] ) ->
(match e1.pexp_desc with
| Pexp_ident { txt = Lident "_"; _ } ->
let k = atom "Array.get" in
let v =
makeList
~postSpace:true
~sep:(Layout.Sep ",")
~wrap:("(", ")")
[ atom "_"; self#unparseExpr e2 ]
in
Simple (label k v)
| _ ->
let prec = Custom "prec_lbracket" in
let lhs =
self#unparseResolvedRule
(self#ensureExpression ~reducesOnToken:prec e1)
in
let rhs = self#unparseExpr e2 in
SpecificInfixPrecedence
( { reducePrecedence = prec; shiftPrecedence = prec }
, LayoutNode (self#access "[" "]" lhs rhs) ))
| ( { pexp_desc =
Pexp_ident { txt = Ldot (Lident "String", "get"); _ }
; _
}
, [ (_, e1); (_, e2) ] ) ->
if Reason_heuristics.isUnderscoreIdent e1
then
let k = atom "String.get" in
let v =
makeList
~postSpace:true
~sep:(Layout.Sep ",")
~wrap:("(", ")")
[ atom "_"; self#unparseExpr e2 ]
in
Simple (label k v)
else
let prec = Custom "prec_lbracket" in
let lhs =
self#unparseResolvedRule
(self#ensureExpression ~reducesOnToken:prec e1)
in
let rhs = self#unparseExpr e2 in
SpecificInfixPrecedence
( { reducePrecedence = prec; shiftPrecedence = prec }
, LayoutNode (self#access ".[" "]" lhs rhs) )
| ( { pexp_desc =
Pexp_ident
{ txt =
Ldot (Ldot (Lident "Bigarray", "Genarray"), "get")
; _
}
; _
}
, [ (_, e1); (_, ({ pexp_desc = Pexp_array ls; _ } as e2)) ] )
->
if Reason_heuristics.isUnderscoreIdent e1
then
let k = atom "Bigarray.Genarray.get" in
let v =
makeList
~postSpace:true
~sep:(Layout.Sep ",")
~wrap:("(", ")")
[ atom "_"; self#unparseExpr e2 ]
in
Simple (label k v)
else
let formattedList = List.map ~f:self#unparseExpr ls in
let lhs =
makeList
[ self#simple_enough_to_be_lhs_dot_send e1; atom "." ]
in
let rhs =
makeList
~break:IfNeed
~postSpace:true
~sep:commaSep
~wrap:("{", "}")
formattedList
in
let prec = Custom "prec_lbracket" in
SpecificInfixPrecedence
( { reducePrecedence = prec; shiftPrecedence = prec }
, LayoutNode (label lhs rhs) )
| ( { pexp_desc =
Pexp_ident
{ txt =
Ldot
( Ldot
( Lident "Bigarray"
, (("Array1" | "Array2" | "Array3") as
arrayIdent) )
, "get" )
; _
}
; _
}
, (_, e1) :: rest ) ->
if Reason_heuristics.isUnderscoreIdent e1
then
let k = atom ("Bigarray." ^ arrayIdent ^ ".get") in
let v =
makeList
~postSpace:true
~sep:(Layout.Sep ",")
~wrap:("(", ")")
(atom "_"
:: List.map ~f:(fun (_, e) -> self#unparseExpr e) rest)
in
Simple (label k v)
else
let formattedList =
List.map ~f:self#unparseExpr (List.map ~f:snd rest)
in
let lhs =
makeList
[ self#simple_enough_to_be_lhs_dot_send e1; atom "." ]
in
let rhs =
makeList
~break:IfNeed
~postSpace:true
~sep:commaSep
~wrap:("{", "}")
formattedList
in
let prec = Custom "prec_lbracket" in
SpecificInfixPrecedence
( { reducePrecedence = prec; shiftPrecedence = prec }
, LayoutNode (label lhs rhs) )
| _ ->
(match self#sugar_set_expr_parts x with
(* Returns None if there's attributes - would render as regular function *)
(* Format as if it were an infix function application with identifier "=" *)
| Some (simplyFormatedLeftItm, rightExpr) ->
let tokenPrec = Token updateToken in
let rightItm =
self#ensureContainingRule
~withPrecedence:tokenPrec
~reducesAfterRight:rightExpr
()
in
let leftWithOp =
makeList
~postSpace:true
[ simplyFormatedLeftItm; atom updateToken ]
in
let expr =
label
~space:true
leftWithOp
(self#unparseResolvedRule rightItm)
in
SpecificInfixPrecedence
( { reducePrecedence = tokenPrec
; shiftPrecedence = tokenPrec
}
, LayoutNode expr )
| None ->
(match printedStringAndFixityExpr e, ls with
(* We must take care not to print two subsequent prefix
operators without spaces between them (`! !` could become
`!!` which is totally different). *)
| AlmostSimplePrefix prefixStr, [ (Nolabel, rightExpr) ] ->
let forceSpace =
match rightExpr.pexp_desc with
| Pexp_apply (ee, _) ->
(match printedStringAndFixityExpr ee with
| AlmostSimplePrefix _ -> true
| _ -> false)
| _ -> false
in
let prec = Token prefixStr in
let rightItm =
self#unparseResolvedRule
(self#ensureContainingRule
~withPrecedence:prec
~reducesAfterRight:rightExpr
())
in
SpecificInfixPrecedence
( { reducePrecedence = prec; shiftPrecedence = prec }
, LayoutNode
(label ~space:forceSpace (atom prefixStr) rightItm)
)
| UnaryPostfix postfixStr, [ (Nolabel, leftExpr) ] ->
let forceSpace =
match leftExpr.pexp_desc with
| Pexp_apply (ee, _) ->
(match printedStringAndFixityExpr ee with
| UnaryPostfix "^" | AlmostSimplePrefix _ -> true
| _ -> false)
| _ -> false
in
let leftItm =
match leftExpr.pexp_desc with
| Pexp_apply (e, _) ->
(match printedStringAndFixityExpr e with
| Infix printedIdent
when requireNoSpaceFor printedIdent
|| Reason_heuristics.isPipeFirst e ->
self#unparseExpr leftExpr
| _ -> self#simplifyUnparseExpr leftExpr)
| Pexp_field _ -> self#unparseExpr leftExpr
| _ -> self#simplifyUnparseExpr leftExpr
in
Simple (label ~space:forceSpace leftItm (atom postfixStr))
| ( Infix printedIdent
, [ (Nolabel, leftExpr); (Nolabel, rightExpr) ] ) ->
let infixToken = Token printedIdent in
let rightItm =
self#ensureContainingRule
~withPrecedence:infixToken
~reducesAfterRight:rightExpr
()
in
let leftItm =
self#ensureExpression
~reducesOnToken:infixToken
leftExpr
in
(* Left exprs of infix tokens which we don't print spaces
for (e.g. `##`) need to be wrapped in parens in the
case of postfix `^`. Otherwise, printing will be
ambiguous as `^` is also a valid start of an infix
operator. *)
let formattedLeftItm =
match leftItm with
| LayoutNode x ->
(match leftExpr.pexp_desc with
| Pexp_apply (e, _) ->
(match printedStringAndFixityExpr e with
| UnaryPostfix "^"
when requireNoSpaceFor printedIdent ->
LayoutNode
(formatPrecedence ~loc:leftExpr.pexp_loc x)
| _ -> leftItm)
| _ -> leftItm)
| InfixTree _ -> leftItm
in
let infixTree =
InfixTree (printedIdent, formattedLeftItm, rightItm)
in
SpecificInfixPrecedence
( { reducePrecedence = infixToken
; shiftPrecedence = infixToken
}
, infixTree )
(* Will be rendered as `(+) a b c` which is parsed with
higher precedence than all the other forms unparsed
here.*)
| UnaryPlusPrefix printedIdent, [ (Nolabel, rightExpr) ] ->
let prec = Custom "prec_unary" in
let rightItm =
self#unparseResolvedRule
(self#ensureContainingRule
~withPrecedence:prec
~reducesAfterRight:rightExpr
())
in
let expr =
label ~space:true (atom printedIdent) rightItm
in
SpecificInfixPrecedence
( { reducePrecedence = prec
; shiftPrecedence = Token printedIdent
}
, LayoutNode expr )
| ( (UnaryMinusPrefix printedIdent as x)
, [ (Nolabel, rightExpr) ] )
| ( (UnaryNotPrefix printedIdent as x)
, [ (Nolabel, rightExpr) ] ) ->
let forceSpace =
match x with
| UnaryMinusPrefix _ -> true
| _ ->
(match rightExpr.pexp_desc with
| Pexp_apply
( { pexp_desc = Pexp_ident { txt = Lident s; _ }
; _
}
, _ ) ->
isSimplePrefixToken s
| _ -> false)
in
let prec = Custom "prec_unary" in
let rightItm =
self#unparseResolvedRule
(self#ensureContainingRule
~withPrecedence:prec
~reducesAfterRight:rightExpr
())
in
let expr =
label ~space:forceSpace (atom printedIdent) rightItm
in
SpecificInfixPrecedence
( { reducePrecedence = prec
; shiftPrecedence = Token printedIdent
}
, LayoutNode expr )
(* Will need to be rendered in self#expression as (~-) x y
z. *)
| _, _ ->
(* This case will happen when there is something like * *
Bar.createElement a::1 b::2 [] [@bla] [@JSX] * * At
this point the bla will be stripped (because it's a
visible * attribute) but the JSX will still be
there. *)
(* this case also happens when we have something like: *
List.map((a) => a + 1, numbers); * We got two
"List.map" as Pexp_ident & a list of arguments: * [`(a)
=> a + 1`; `numbers`] * * Another possible case is: *
describe("App", () => * test("math", () => *
Expect.expect(1 + 2) |> toBe(3))); *)
let uncurried =
try Hashtbl.find uncurriedTable x.pexp_loc with
| Not_found -> false
in
FunctionApplication
(self#formatFunAppl
~uncurried
~jsxAttrs
~args:ls
~applicationExpr:x
~funExpr:e
()))))
| Pexp_field (e, li) ->
let prec = Token "." in
let leftItm =
self#unparseResolvedRule
(self#ensureExpression ~reducesOnToken:prec e)
in
let { Reason_attributes.stdAttrs; _ } =
Reason_attributes.partitionAttributes e.pexp_attributes
in
let formattedLeftItm =
if stdAttrs == []
then leftItm
else formatPrecedence ~loc:e.pexp_loc leftItm
in
let layout =
label
(makeList [ formattedLeftItm; atom "." ])
(self#longident_loc li)
in
SpecificInfixPrecedence
( { reducePrecedence = prec; shiftPrecedence = prec }
, LayoutNode layout )
| Pexp_construct (li, Some eo)
when not (is_simple_construct (view_expr x)) ->
(match view_expr x with
(* TODO: Explicit arity *)
| `normal ->
let arityIsClear = isArityClear arityAttrs in
FunctionApplication
[ self#constructor_expression
~arityIsClear
stdAttrs
(self#longident_loc li)
eo
]
| _ -> assert false)
| Pexp_variant (l, Some eo) ->
if arityAttrs != []
then
raise
(NotPossible
"Should never see embedded attributes on poly variant")
else
FunctionApplication
[ self#constructor_expression
~polyVariant:true
~arityIsClear:true
stdAttrs
(atom ("`" ^ add_raw_identifier_prefix l))
eo
]
(* TODO: Should protect this identifier *)
| Pexp_setinstvar (s, rightExpr) ->
let rightItm =
self#unparseResolvedRule
(self#ensureContainingRule
~withPrecedence:(Token updateToken)
~reducesAfterRight:rightExpr
())
in
let expr =
label
~space:true
(makeList
~postSpace:true
[ protectIdentifier s.txt; atom updateToken ])
rightItm
in
SpecificInfixPrecedence
( { reducePrecedence = Token updateToken
; shiftPrecedence = Token updateToken
}
, LayoutNode expr )
| Pexp_setfield (leftExpr, li, rightExpr) ->
let rightItm =
self#unparseResolvedRule
(self#ensureContainingRule
~withPrecedence:(Token updateToken)
~reducesAfterRight:rightExpr
())
in
let leftItm =
self#unparseResolvedRule
(self#ensureExpression ~reducesOnToken:(Token ".") leftExpr)
in
let leftLbl =
label (makeList [ leftItm; atom "." ]) (self#longident_loc li)
in
let expr =
label
~space:true
(makeList ~postSpace:true [ leftLbl; atom updateToken ])
rightItm
in
SpecificInfixPrecedence
( { reducePrecedence = Token updateToken
; shiftPrecedence = Token updateToken
}
, LayoutNode expr )
| Pexp_match (e, l) when detectTernary l != None ->
(match detectTernary l with
| None -> raise (Invalid_argument "Impossible")
| Some (tt, ff) ->
let ifTrue = self#reset_request_braces#unparseExpr tt in
let testItem =
self#unparseResolvedRule
(self#reset_request_braces#ensureExpression
e
~reducesOnToken:(Token "?"))
in
let ifFalse =
self#unparseResolvedRule
(self#reset_request_braces#ensureContainingRule
~withPrecedence:(Token ":")
~reducesAfterRight:ff
())
in
let trueBranch =
label ~space:true ~break:`Never (atom "?") ifTrue
in
let falseBranch =
label ~space:true ~break:`Never (atom ":") ifFalse
in
let expr =
label
~space:true
testItem
(makeList
~break:IfNeed
~sep:(Sep " ")
~inline:(true, true)
[ trueBranch; falseBranch ])
in
SpecificInfixPrecedence
( { reducePrecedence = Token ":"
; shiftPrecedence = Token "?"
}
, LayoutNode expr ))
| _ ->
(match self#expression_requiring_parens_in_infix x with
| Some e -> e
| None ->
raise (Invalid_argument "No match for unparsing expression"))))
method formatNonSequencyExpression ?parent e =
(* Instead of printing:
* let result = { open Fmt; strf(foo);}
*
* We format as:
* let result = Fmt.(strf(foo))
*
* (Also see https://github.com/facebook/Reason/issues/114)
*)
match e.pexp_attributes, e.pexp_desc with
| [], Pexp_record _ (* syntax sugar for M.{x:1} *)
| [], Pexp_tuple _ (* syntax sugar for M.(a, b) *)
| [], Pexp_object { pcstr_fields = []; _ } (* syntax sugar for M.{} *)
| [], Pexp_construct ({ txt = Lident "::"; _ }, Some _)
| [], Pexp_construct ({ txt = Lident "[]"; _ }, _)
| [], Pexp_extension ({ txt = "mel.obj"; _ }, _) ->
self#simplifyUnparseExpr e (* syntax sugar for M.[x,y] *)
(* syntax sugar for the rest, wrap with parens to avoid ambiguity.
* E.g., avoid M.(M2.v) being printed as M.M2.v
* Or ReasonReact.(<> {string("Test")} </>);
*)
| _ ->
(match parent with
| Some parent
when Reason_attributes.has_open_notation_attr
parent.pexp_attributes ->
makeList
~break:IfNeed
~inline:(true, false)
~postSpace:true
~wrap:("(", ")")
~sep:(SepFinal (";", ""))
(self#letList e)
| Some _ | None ->
makeList ~wrap:("(", ")") ~break:IfNeed [ self#unparseExpr e ])
(* It's not enough to only check if precedence of an infix left/right is
* greater than the infix itself. We also should likely pay attention to
* left/right associativity. So how do we render the minimum number of
* parenthesis?
*
* The intuition is that sequential right associative operators will
* naturally build up deep trees on the right side (left builds up left-deep
* trees). So by default, we add parens to model the tree structure that
* we're rendering except when the parser will *naturally* parse the tree
* structure that the parens assert.
*
* Sequential identical infix operators:
* ------------------------------------
* So if we see a nested infix operator of precedence Y, as one side of
* another infix operator that has the same precedence (Y), that is S
* associative on the S side of the function application, we don't need to
* wrap in parens. In more detail:
*
* -Add parens around infix binary function application
* Exception 1: Unless we are a left-assoc operator of precedence X in the left branch of an operator w/ precedence X.
* Exception 2: Unless we are a right-assoc operator of precedence X in the right branch of an operator w/ precedence X.
* Exception 3: Unless we are a _any_-assoc X operator in the _any_ branch of an Y operator where X has greater precedence than Y.
*
* Note that the exceptions do not specify any special cases for mixing
* left/right associativity. Precedence is what determines necessity of
* parens for operators with non-identical precedences. Associativity
* only determines necessity of parens for identically precedented operators.
*
* PLUS is left assoc:
* - So this one *shouldn't* expand into two consecutive infix +:
*
*
* [Pexp_apply]
* / \
* first + [Pexp_apply]
* / \
* second + third
*
*
* - This one *should*:
*
* [Pexp_apply]
* / \
* [ Pexp_apply ] + third
* / \
* first + second
*
*
* COLONCOLON is right assoc, so
* - This one *should* expand into two consecutive infix :: :
*
* [Pexp_apply]
* / \
* first :: [Pexp_apply]
* / \
* second :: third
*
*
* - This one *shouldn't*:
*
* [Pexp_apply]
* / \
* [ Pexp_apply ] :: third
* / \
* first :: second
*
*
* Sequential differing infix operators:
* ------------------------------------
*
* Neither of the following require paren grouping because of rule 3.
*
*
* [Pexp_apply]
* / \
* first + [Pexp_apply]
* / \
* second * third
*
*
* [Pexp_apply]
* / \
* [Pexp_apply + third
* / \
* first * second
*
* The previous has nothing to do with the fact that + and * have the same
* associativity. Exception 3 applies to the following where :: is right assoc
* and + is left. + has higher precedence than ::
*
* - so parens aren't required to group + when it is in a branch of a
* lower precedence ::
*
* [Pexp_apply]
* / \
* first :: [Pexp_apply]
* / \
* second + third
*
*
* - Whereas there is no Exception that applies in this case (Exception 3
* doesn't apply) so parens are required around the :: in this case.
*
* [Pexp_apply]
* / \
* [ Pexp_apply ] + third
* / \
* first :: second
*)
method classExpressionToFormattedApplicationItems =
function
| { pcl_desc = Pcl_apply (ce, l); _ } ->
[ label
(self#simple_class_expr ce)
(self#label_x_expression_params l)
]
| x -> [ self#class_expr x ]
method dotdotdotChild expr =
let self = self#inline_braces in
match expr with
| { pexp_desc = Pexp_apply (funExpr, args); _ }
when printedStringAndFixityExpr funExpr == Normal
&& Reason_attributes.without_stylistic_attrs
expr.pexp_attributes
== [] ->
(match
self#formatFunAppl
~prefix:(atom "...")
~wrap:("{", "}")
~jsxAttrs:[]
~args
~funExpr
~applicationExpr:expr
()
with
| [ x ] -> x
| xs -> makeList xs)
| { pexp_desc = Pexp_function (_ :: _, _, Pfunction_body _); _ } ->
self#formatPexpFun ~prefix:(atom "...") ~wrap:("{", "}") expr
| _ ->
(* Currently spreading a list must be wrapped in { }.
* You can remove the entire even_wrap_simple arg when that is fixed. *)
let even_wrap_simple =
match expr with
| { pexp_desc =
Pexp_construct
( { txt = Lident "::"; _ }
, Some { pexp_desc = Pexp_tuple _; _ } )
; _
} ->
not (Reason_attributes.has_jsx_attributes expr.pexp_attributes)
| _ -> false
in
let childLayout =
self#dont_preserve_braces#simplifyUnparseExpr
~even_wrap_simple
~wrap:("{", "}")
expr
in
makeList ~break:Never [ atom "..."; childLayout ]
(* How JSX is formatted/wrapped. We want the attributes to wrap
independently * of children. * * <xxx * attr1=blah * attr2=foo> *
child * child * child * </x> * * +-------------------------------+ *
| left right (list of attrs) | * | / \ / \ | * | <tag | * |
attr1=blah | * | attr2=foo | * +-------------------------------+ * |
* | * | * | left right list of children with * | / \ / \ open,close =
> </tag> * | +---------+ * +--| | > * +---------+ * * </tag> *)
method formatJSXComponent componentName ?closeComponentName args =
let self = self#inline_braces in
let rec processArguments arguments processedAttrs children =
match arguments with
| (Labelled "children", { pexp_desc = Pexp_construct (_, None); _ })
:: tail ->
processArguments tail processedAttrs None
| ( Labelled "children"
, ({ pexp_desc =
Pexp_construct
( { txt = Lident "::"; _ }
, Some { pexp_desc = Pexp_tuple _; _ } )
; _
} as arg) )
:: tail ->
(match self#formatJsxChildrenNonSpread arg [] with
(* Back out of the standard jsx child formatting *)
| None ->
processArguments
tail
processedAttrs
(Some [ self#dotdotdotChild arg ])
| Some chldn -> processArguments tail processedAttrs (Some chldn))
| (Labelled "children", expr) :: tail ->
processArguments
tail
processedAttrs
(Some [ self#dotdotdotChild expr ])
| (Optional lbl, expression) :: tail ->
let { Reason_attributes.jsxAttrs; stdAttrs; _ } =
Reason_attributes.partitionAttributes expression.pexp_attributes
in
let value_has_jsx = jsxAttrs != [] in
let nextAttr =
match expression.pexp_desc with
| Pexp_ident ident when isPunnedJsxArg lbl ident stdAttrs ->
makeList ~break:Layout.Never [ atom "?"; atom lbl ]
| Pexp_construct _ when value_has_jsx ->
label
(makeList ~break:Layout.Never [ atom lbl; atom "=?" ])
(self#simplifyUnparseExpr ~wrap:("{", "}") expression)
| _ ->
label
(makeList ~break:Layout.Never [ atom lbl; atom "=?" ])
(self#dont_preserve_braces#simplifyUnparseExpr
~wrap:("{", "}")
expression)
in
processArguments tail (nextAttr :: processedAttrs) children
| (Labelled lbl, expression) :: tail ->
let { Reason_attributes.jsxAttrs; stdAttrs; _ } =
Reason_attributes.partitionAttributes expression.pexp_attributes
in
let value_has_jsx = jsxAttrs != [] in
let nextAttr =
match expression.pexp_desc with
| Pexp_ident ident when isPunnedJsxArg lbl ident stdAttrs ->
atom lbl
| _ when isJSXComponent expression ->
label
(atom (lbl ^ "="))
(makeList
~break:IfNeed
~wrap:("{", "}")
[ self#dont_preserve_braces#simplifyUnparseExpr
expression
])
| Pexp_open (me, e)
when self#isSeriesOfOpensFollowedByNonSequencyExpression
expression ->
label
(makeList
[ atom lbl
; atom "="
; label
(self#moduleExpressionToFormattedApplicationItems
me.popen_expr)
(atom ".")
])
(self#formatNonSequencyExpression e)
| Pexp_apply (({ pexp_desc = Pexp_ident _; _ } as funExpr), args)
when printedStringAndFixityExpr funExpr == Normal
&& Reason_attributes.without_stylistic_attrs
expression.pexp_attributes
== [] ->
let lhs = makeList [ atom lbl; atom "=" ] in
(match
self#formatFunAppl
~prefix:lhs
~wrap:("{", "}")
~jsxAttrs:[]
~args
~funExpr
~applicationExpr:expression
()
with
| [ x ] -> x
| xs -> makeList xs)
| Pexp_apply (eFun, _) ->
let lhs = makeList [ atom lbl; atom "=" ] in
let rhs =
match printedStringAndFixityExpr eFun with
| Infix str when requireNoSpaceFor str ->
self#unparseExpr expression
| _ ->
self#dont_preserve_braces#simplifyUnparseExpr
~wrap:("{", "}")
expression
in
label lhs rhs
| Pexp_construct _ when value_has_jsx ->
label
(makeList [ atom lbl; atom "=" ])
(self#simplifyUnparseExpr ~wrap:("{", "}") expression)
| Pexp_record _ | Pexp_construct _ | Pexp_array _ | Pexp_tuple _
| Pexp_match _ | Pexp_extension _
| Pexp_function (_, _, Pfunction_cases _) ->
label
(makeList [ atom lbl; atom "=" ])
(self#dont_preserve_braces#simplifyUnparseExpr
~wrap:("{", "}")
expression)
| Pexp_function (_ :: _, _, Pfunction_body _) ->
let propName = makeList [ atom lbl; atom "=" ] in
self#formatPexpFun
~wrap:("{", "}")
~prefix:propName
expression
| _ ->
makeList
[ atom lbl
; atom "="
; self#dont_preserve_braces#simplifyUnparseExpr
~wrap:("{", "}")
expression
]
in
processArguments tail (nextAttr :: processedAttrs) children
| [] -> processedAttrs, children
| _ :: tail -> processArguments tail processedAttrs children
in
let reversedAttributes, children = processArguments args [] None in
match children with
| None ->
makeList
~break:IfNeed
~wrap:("<" ^ componentName, "/>")
~pad:(true, true)
~inline:(false, false)
~postSpace:true
(List.rev reversedAttributes)
| Some renderedChildren ->
let openTagAndAttrs =
match reversedAttributes with
| [] -> atom ("<" ^ componentName ^ ">")
| revAttrHd :: revAttrTl ->
let finalAttrList =
List.rev
(makeList ~break:Layout.Never [ revAttrHd; atom ">" ]
:: revAttrTl)
in
let renderedAttrList =
makeList
~inline:(true, true)
~break:IfNeed
~pad:(false, false)
~preSpace:true
finalAttrList
in
label ~space:true (atom ("<" ^ componentName)) renderedAttrList
in
label
openTagAndAttrs
(makeList
~wrap:
( ""
, "</"
^ (match closeComponentName with
| None -> componentName
| Some close -> close)
^ ">" )
~inline:(true, false)
~break:IfNeed
~pad:(true, true)
~postSpace:true
renderedChildren)
(* Format Pexp_fun expression: (a, b) => a + b;
* Example: the `onClick` prop with Pexp_fun in
* <div
* onClick={(event) => {
* Js.log(event);
* handleChange(event);
* }}
* />;
*
* The arguments of the callback (Pexp_fun) should be inlined as much as
* possible on the same line as `onClick={`.
* Also notice the brace-hugging `}}` at the end.
*
* ~prefix -> prefixes the Pexp_fun layout, example `onClick=`
* ~wrap -> wraps the `Pexp_fun` in the tuple passed to wrap, e.g. `{` and
* `}` for jsx
*)
method formatPexpFun ?(prefix = atom "") ?(wrap = "", "") expression =
let lwrap, rwrap = wrap in
let { Reason_attributes.stdAttrs; uncurried; _ } =
Reason_attributes.partitionAttributes expression.pexp_attributes
in
if uncurried then Hashtbl.add uncurriedTable expression.pexp_loc true;
let args, ret =
(* omit attributes here, we're formatting them manually *)
self#curriedPatternsAndReturnVal
{ expression with pexp_attributes = [] }
in
(* Format `onClick={` *)
let propName = makeList ~wrap:("", lwrap) [ prefix ] in
let argsList =
let args =
match args with [ argsList ] -> argsList | args -> makeList args
in
match stdAttrs with
| [] -> args
| attrs ->
(* attach attributes to the args of the Pexp_fun: `[@attr]
(event)` *)
let attrList =
makeList
~inline:(true, true)
~break:IfNeed
~postSpace:true
(List.map ~f:self#attribute attrs)
in
let all = [ attrList; args ] in
makeList ~break:IfNeed ~inline:(true, true) ~postSpace:true all
in
(* Format `onClick={(event)` *)
let propNameWithArgs = label propName argsList in
(* Pick constraints: (a, b) :string => ... * :string is the constraint
here *)
let return, optConstr =
match ret.pexp_desc with
| Pexp_constraint (e, ct) -> e, Some (self#non_arrowed_core_type ct)
| _ -> ret, None
in
let returnExpr, leftWrap =
match self#letList return with
| [ x ] ->
(* Format `handleChange(event)}` or
* handleChange(event)
* }
*
* If the closing rwrap is empty, we need it to be inline, otherwise
* we get a empty newline when the layout breaks:
* ```
* handleChange(event)
*
* ```
* (Notice to nonsense newline)
*)
let shouldPreserveBraces =
self#should_preserve_requested_braces return
in
let rwrap = if shouldPreserveBraces then "}" ^ rwrap else rwrap in
let inlineClosing = rwrap = "" in
let layout =
makeList
~break:IfNeed
~inline:(true, inlineClosing)
~wrap:("", rwrap)
[ x ]
in
layout, if shouldPreserveBraces then "{" else ""
| xs ->
(* Format `Js.log(event)` and `handleChange(event)` as
* {
* Js.log(event);
* handleChange(event);
* }}
*)
let layout =
makeList
~break:Always_rec
~sep:(SepFinal (";", ";"))
~wrap:("{", "}" ^ rwrap)
xs
in
layout, ""
in
match optConstr with
| Some typeConstraint ->
let upToConstraint =
label
~space:true
(makeList ~wrap:("", ":") [ propNameWithArgs ])
typeConstraint
in
label
(makeList ~wrap:("", " => " ^ leftWrap) [ upToConstraint ])
returnExpr
| None ->
label
(makeList ~wrap:("", " => " ^ leftWrap) [ propNameWithArgs ])
returnExpr
(* Creates a list of simple module expressions corresponding to module
expression or functor application. *)
method moduleExpressionToFormattedApplicationItems ?(prefix = "") x =
match x with
(* are we formatting a functor application with a module structure as arg?
* YourLib.Make({
* type t = int;
* type s = string;
* });
*
* We should "hug" the parens here: ({ & }) should stick together.
*)
| { pmod_desc =
Pmod_apply
( ({ pmod_desc = Pmod_ident _; _ } as m1)
, ({ pmod_desc = Pmod_structure _; _ } as m2) )
; _
} ->
let modIdent =
source_map ~loc:m1.pmod_loc (self#simple_module_expr m1)
in
let name =
if prefix <> ""
then makeList ~postSpace:true [ atom prefix; modIdent ]
else modIdent
in
let arg =
source_map ~loc:m2.pmod_loc (self#simple_module_expr ~hug:true m2)
in
label name arg
| _ ->
let rec extract_apps args = function
| { pmod_desc = Pmod_apply_unit me; _ } ->
let head = source_map ~loc:me.pmod_loc (self#module_expr me) in
label head (makeTup args)
| { pmod_desc = Pmod_apply (me1, me2); _ } ->
let arg =
source_map ~loc:me2.pmod_loc (self#simple_module_expr me2)
in
extract_apps (arg :: args) me1
| me ->
let head = source_map ~loc:me.pmod_loc (self#module_expr me) in
if args == [] then head else label head (makeTup args)
in
let functor_application = extract_apps [] x in
if prefix <> ""
then makeList ~postSpace:true [ atom prefix; functor_application ]
else functor_application
(* Watch out, if you see something like below (sixteenTuple getting put
on a * newline), yet a paren-wrapped list wouldn't have had an extra
newlin, you * might need to wrap the single token (sixteenTuple) in
[ensureSingleTokenSticksToLabel]. * let ( * axx, * oxx, * pxx * ): *
sixteenTuple = echoTuple ( * 0, * 0, * 0 * ); *)
method formatSimplePatternBinding
?(wrap=false)
labelOpener
layoutPattern
typeConstraint
appTerms =
let letPattern =
let layoutPattern =
match typeConstraint, wrap with
| (Some (_, `Constraint), true) -> makeList ~wrap:("(","") [layoutPattern]
| (Some _ | None), _ -> layoutPattern
in
label ~break:`Never ~space:true (atom labelOpener) layoutPattern
in
let upUntilEqual =
match typeConstraint with
| None -> letPattern
| Some (tc, `Constraint) ->
makeList ~wrap:(("", if wrap then ")" else "")) [ formatTypeConstraint letPattern tc ]
| Some (tc, `Coercion ground) -> formatCoerce letPattern ground tc
in
let includingEqual =
makeList ~postSpace:true [ upUntilEqual; atom "=" ]
in
formatAttachmentApplication
applicationFinalWrapping
(Some (true, includingEqual))
appTerms
(* The [bindingLabel] is either the function name (if let binding) or first
* arg (if lambda).
*
* For defining layout of the following form:
*
* lbl one
* two
* constraint => {
* ...
* }
*
* If using "=" as the arrow, can also be used for:
*
* met private
* myMethod
* constraint = fun ...
*
*)
method wrapCurriedFunctionBinding
?attachTo
~arrow
?(sweet = false)
?(spaceBeforeArrow = true)
prefixText
bindingLabel
patternList
returnedAppTerms =
let allPatterns = bindingLabel :: patternList in
let partitioning = curriedFunctionFinalWrapping allPatterns in
let everythingButReturnVal =
(* Because align_closing is set to false, you get: * * (Brackets[]
inserted to show boundaries between open/close of pattern list) *
let[firstThing * secondThing * thirdThing] * * It only wraps to
indent four by coincidence: If the "opening" token was * longer,
you'd get: * * letReallyLong[firstThing * secondThing *
thirdThing] * * For curried let bindings, we stick the arrow in
the *last* pattern: * let[firstThing * secondThing * thirdThing
=>] * * But it could have just as easily been the "closing" token
corresponding to * "let". This works because we have
[align_closing = false]. The benefit of * shoving it in the last
pattern, is that we can turn [align_closing = true] * and still
have the arrow stuck to the last pattern (which is usually what
we * want) (See modeTwo below). *)
match partitioning with
| None when sweet ->
makeList
~pad:(false, spaceBeforeArrow)
~wrap:("", arrow)
~indent:(settings.space * settings.indentWrappedPatternArgs)
~postSpace:true
~inline:(true, true)
~break:IfNeed
allPatterns
| None ->
(* We want the binding label to break *with* the arguments. Again,
there's no apparent way to add additional indenting for the
args with this setting. *)
(* Formats lambdas by treating the first pattern as the *
"bindingLabel" which is kind of strange in some cases (when *
you only have one arg that wraps)... * * echoTheEchoer ( * fun
( * a, * p * ) => ( * a, * b * ) * * But it makes sense in
others (where you have multiple args): * * echoTheEchoer ( *
fun ( * a, * p * ) * mySecondArg * myThirdArg => ( * a, * b * )
* * Try any other convention for wrapping that first arg and it
* won't look as balanced when adding multiple args. *)
makeList
~pad:(true, spaceBeforeArrow)
~wrap:(prefixText, arrow)
~indent:(settings.space * settings.indentWrappedPatternArgs)
~postSpace:true
~inline:(true, true)
~break:IfNeed
allPatterns
| Some (attachedList, wrappedListy) ->
(* To get *only* the final argument to "break", while not
necessarily breaking the prior arguments, we dock everything
but the last item to a created label *)
label
~space:true
(makeList
~pad:(true, spaceBeforeArrow)
~wrap:(prefixText, arrow)
~indent:(settings.space * settings.indentWrappedPatternArgs)
~postSpace:true
~inline:(true, true)
~break:IfNeed
attachedList)
wrappedListy
in
let everythingButAppTerms =
match attachTo with
| None -> everythingButReturnVal
| Some toThis -> label ~space:true toThis everythingButReturnVal
in
formatAttachmentApplication
applicationFinalWrapping
(Some (true, everythingButAppTerms))
returnedAppTerms
method leadingCurriedAbstractTypes x =
let rec argsAndReturn xx =
match xx.pexp_desc with
| Pexp_newtype (str, e) ->
let nextArgs, return = argsAndReturn e in
str :: nextArgs, return
| _ -> [], xx.pexp_desc
in
argsAndReturn x
method curriedConstructorPatternsAndReturnVal cl =
let rec argsAndReturn args = function
| { pcl_desc = Pcl_fun (label, eo, p, e); pcl_attributes = []; _ }
->
let arg =
source_map ~loc:p.ppat_loc (self#label_exp label eo p)
in
argsAndReturn (arg :: args) e
| xx ->
if args == []
then None, xx
else Some (makeTup (List.rev args)), xx
in
argsAndReturn [] cl
(* Returns the arguments list (if any, that occur before the =>), and
the final expression (that is either returned from the function
(after =>) or that is bound to the value (if there are no arguments,
and this is just a let pattern binding)). *)
method curriedPatternsAndReturnVal x =
let uncurried =
try Hashtbl.find uncurriedTable x.pexp_loc with Not_found -> false
in
let rec extract_args =
let extract_from_params param =
match param.pparam_desc with
| Pparam_val (lbl, eo, pat) -> `Value (lbl, eo, pat)
| Pparam_newtype newtype -> `Type newtype
in
fun xx ->
let { Reason_attributes.stdAttrs; _ } =
Reason_attributes.partitionAttributes
~allowUncurry:false
xx.pexp_attributes
in
if stdAttrs != []
then [], xx
else
match xx.pexp_desc with
| Pexp_function (params, constraint_, body) ->
let vs = List.map ~f:extract_from_params params in
(match constraint_, body with
| Some (Pconstraint ct), Pfunction_body e ->
vs, { e with pexp_desc = Pexp_constraint (e, ct) }
| Some (Pcoerce (ground, coercion)), Pfunction_body e ->
vs, { e with pexp_desc = Pexp_coerce (e, ground, coercion) }
| Some _, (Pfunction_cases _ as c) ->
vs, { xx with pexp_desc = Pexp_function ([], constraint_, c) }
| None, (Pfunction_cases _ as c) ->
vs, { xx with pexp_desc = Pexp_function ([], None, c) }
| None, Pfunction_body e ->
let args, ret = extract_args e in
vs @ args, ret)
| Pexp_newtype (newtype, e) ->
let args, ret = extract_args e in
`Type newtype :: args, ret
| Pexp_constraint _ -> [], xx
| _ -> [], xx
in
let prepare_arg = function
| `Value (l, eo, p) ->
source_map ~loc:p.ppat_loc (self#label_exp l eo p)
| `Type nt -> atom ("type " ^ nt.txt)
in
let single_argument_no_parens p ret =
if uncurried
then false
else
let isUnitPat = is_unit_pattern p in
let isAnyPat = is_any_pattern p in
match ret.pexp_desc with
(* (event) :ReasonReact.event => {...}
* The above Pexp_fun with constraint ReasonReact.event requires parens
* surrounding the single argument `event`.*)
| Pexp_constraint _ when (not isUnitPat) && not isAnyPat -> false
| _ -> isUnitPat || isAnyPat || is_ident_pattern p
in
match extract_args x with
| [], ret -> [], ret
| [ `Value (Nolabel, None, p) ], ret
when is_unit_pattern p && uncurried ->
[ atom "(.)" ], ret
| [ (`Value (Nolabel, None, p) as arg) ], ret
when single_argument_no_parens p ret ->
[ prepare_arg arg ], ret
| args, ret ->
[ makeTup ~uncurried (List.map ~f:prepare_arg args) ], ret
(* Returns the (curriedModule, returnStructure) for a functor *)
method curriedFunctorPatternsAndReturnStruct =
function
(* string loc * module_type option * module_expr *)
| { pmod_desc = Pmod_functor (fp, me2); _ } ->
let firstOne =
match fp with
| Unit -> atom ""
| Named (s, mt') ->
let s = moduleIdent s in
self#module_type (makeList [ atom s; atom ":" ]) mt'
in
let functorArgsRecurse, returnStructure =
self#curriedFunctorPatternsAndReturnStruct me2
in
firstOne :: functorArgsRecurse, returnStructure
| me -> [], me
method isRenderableAsPolymorphicAbstractTypes
typeVars
polyType
leadingAbstractVars
nonVarifiedType =
same_ast_modulo_varification_and_extensions polyType nonVarifiedType
&& for_all2' string_loc_equal typeVars leadingAbstractVars
(* Reinterpret this as a pattern constraint since we don't currently
have a * way to disambiguate. There is currently a way to
disambiguate a parsing * from Ppat_constraint vs. Pexp_constraint.
Currently (and consistent with * OCaml standard parser):
* let (x: typ) = blah; * Becomes Ppat_constraint * let x:poly . type
= blah; * Becomes Ppat_constraint * let x:typ = blah; * Becomes
Pexp_constraint(ghost) * let x = (blah:typ); * Becomes
Pexp_constraint(ghost) * * How are double constraints represented? *
let (x:typ) = (blah:typ); * If currently both constraints are parsed
into a single Pexp_constraint, * then something must be lost, and how
could you fail type checking on: * let x:int = (10:string) ?? Answer:
It probably parses into a nested * Pexp_constraint. * * Proposal: * *
let (x: typ) = blah; * Becomes Ppat_constraint (still) * let x:poly .
type = blah; * Becomes Ppat_constraint (still) * let x:typ = blah; *
Becomes Ppat_constraint * let x = blah:typ; * Becomes Pexp_constraint
* * * Reasoning: Allows parsing of any of the currently valid ML
forms, but * combines the two most similar into one form. The only
lossyness is the * unnecessary parens, which there is already
precedence for dropping in * expressions. In the existing approach,
preserving a paren-constrained * expression is *impossible* because
it becomes pretty printed as * let x:t =.... In the proposal, it is
not impossible - it is only * impossible to preserve unnecessary
parenthesis around the let binding. * * The one downside is that
integrating with existing code that uses [let x = * (blah:typ)] in
standard OCaml will be parsed as a Pexp_constraint. There * might be
some lossiness (beyond parens) that occurs in the original OCaml *
parser. *)
method locallyAbstractPolymorphicFunctionBinding
prefixText
layoutPattern
funWithNewTypes
absVars
bodyType =
let appTerms = self#unparseExprApplicationItems funWithNewTypes in
let locallyAbstractTypes =
List.map ~f:(fun x -> atom x.txt) absVars
in
let typeLayout =
source_map ~loc:bodyType.ptyp_loc (self#core_type bodyType)
in
let polyType =
label
~space:true
(* TODO: This isn't a correct use of sep! It ruins how * comments
are interleaved. *)
(makeList
[ makeList ~sep:(Sep " ") (atom "type" :: locallyAbstractTypes)
; atom "."
])
typeLayout
in
self#formatSimplePatternBinding
prefixText
layoutPattern
(Some (polyType, `Constraint))
appTerms
(* Intelligently switches between:
* Curried function binding w/ constraint on return expr:
* lbl patt
* pattAux
* arg
* :constraint => {
* ...
* }
*
* Constrained:
* lbl patt
* pattAux...
* :constraint = {
* ...
* }
*)
method wrappedBinding prefixText ~arrow ?vbct pattern patternAux expr =
let expr = self#process_underscore_application expr in
let argsList, return = self#curriedPatternsAndReturnVal expr in
let patternList =
match patternAux with
| [] -> pattern
| _ :: _ ->
makeList
~postSpace:true
~inline:(true, true)
~break:IfNeed
(pattern :: patternAux)
in
match argsList, return.pexp_desc with
| [], Pexp_constraint (e, ct) when vbct = None ->
let typeLayout =
source_map
~loc:ct.ptyp_loc
(match ct.ptyp_desc with
| Ptyp_package (li, cstrs) -> self#typ_package li cstrs
| _ -> self#core_type ct)
in
let appTerms = self#unparseExprApplicationItems e in
self#formatSimplePatternBinding
prefixText
patternList
(Some (typeLayout, `Constraint))
appTerms
| [], _ ->
(* simple let binding, e.g. `let number = 5` *)
(* let f = (. a, b) => a + b; *)
let appTerms = self#unparseExprApplicationItems expr in
self#formatSimplePatternBinding prefixText patternList vbct appTerms
| _ :: _, _ ->
let argsWithConstraint, actualReturn =
self#normalizeFunctionArgsConstraint argsList return
in
let fauxArgs = List.concat [ patternAux; argsWithConstraint ] in
let returnedAppTerms =
self#unparseExprApplicationItems actualReturn
in
(* Attaches the `=` to `f` to recreate javascript function syntax in
* let f = (a, b) => a + b; *)
let lbl =
let pattern =
match vbct with
| None -> pattern
| Some (x, `Constraint) ->
label ~indent:0 pattern (formatJustTheTypeConstraint x)
| Some (x, `Coercion ground) ->
label ~indent:0 pattern (formatJustCoerce ground x)
in
makeList ~sep:(Sep " ") ~break:Layout.Never [ pattern; atom "=" ]
in
self#wrapCurriedFunctionBinding
prefixText
~arrow
lbl
fauxArgs
returnedAppTerms
(* Similar to the above method. *)
method wrappedClassBinding prefixText pattern patternAux expr =
let args, return = self#curriedConstructorPatternsAndReturnVal expr in
let patternList =
match patternAux with
| [] -> pattern
| _ :: _ ->
makeList
~postSpace:true
~inline:(true, true)
~break:IfNeed
(pattern :: patternAux)
in
match args, return.pcl_desc with
| None, Pcl_constraint (e, ct) ->
let typeLayout =
source_map ~loc:ct.pcty_loc (self#class_constructor_type ct)
in
self#formatSimplePatternBinding
prefixText
patternList
(Some (typeLayout, `Constraint))
(self#classExpressionToFormattedApplicationItems e, None)
| None, _ ->
self#formatSimplePatternBinding
prefixText
patternList
None
(self#classExpressionToFormattedApplicationItems expr, None)
| Some args, _ ->
let argsWithConstraint, actualReturn =
self#normalizeConstructorArgsConstraint [ args ] return
in
let fauxArgs = List.concat [ patternAux; argsWithConstraint ] in
self#wrapCurriedFunctionBinding
prefixText
~arrow:"="
pattern
fauxArgs
( self#classExpressionToFormattedApplicationItems actualReturn
, None )
(* Attaches doc comments to a layout, with whitespace preserved *
Example: * /** Doc comment */ * * /* another random comment */ * let
a = 1; *)
method attachDocAttrsToLayout
~(* all std attributes attached on the ast node backing the layout *)
(stdAttrs : Parsetree.attributes)
~(* all doc comments attached on the ast node backing the layout *)
(docAttrs : Parsetree.attributes)
~(* location of the layout *)
loc
~(* layout to attach the doc comments to *)
layout
() =
(* compute the correct location of layout * Example: * 1| /**
doc-comment */ * 2| * 3| [@attribute] * 4| let a = 1; * * The
location might indicate a start of line 4 for the ast-node *
representing `let a = 1`. The reality is that `[@attribute]` should
be * included (start of line 3), to represent the correct start
location * of the whole layout. *)
let loc =
match stdAttrs with
| { attr_name = astLoc; _ } :: _ -> astLoc.loc
| [] -> loc
in
let rec aux prevLoc layout = function
| ({ attr_name = x; _ } as attr : Parsetree.attribute) :: xs ->
let newLayout =
let range = Range.makeRangeBetween x.loc prevLoc in
let layout =
if Range.containsWhitespace ~range ~comments:self#comments ()
then
let region = WhitespaceRegion.make ~range ~newlines:1 in
Layout.Whitespace (region, layout)
else layout
in
makeList
~inline:(true, true)
~break:Always
[ self#attribute attr; layout ]
in
aux x.loc newLayout xs
| [] -> layout
in
aux loc layout (List.rev docAttrs)
method value_binding
prefixText
{ pvb_pat; pvb_attributes; pvb_loc; pvb_expr; pvb_constraint } =
self#binding
prefixText
~attrs:pvb_attributes
~loc:pvb_loc
~pat:pvb_pat
?pvb_constraint
pvb_expr
method binding_op prefixText { pbop_pat; pbop_loc; pbop_exp; _ } =
self#binding
(Reason_syntax_util.escape_stars_slashes prefixText)
~loc:pbop_loc
~pat:pbop_pat
pbop_exp
method binding prefixText ?(attrs = []) ~loc ~pat ?pvb_constraint expr =
(* TODO: print attributes *)
let body =
let vbct =
match pvb_constraint with
| Some (Pvc_constraint { locally_abstract_univars = []; typ }) ->
Some (self#core_type typ, `Constraint)
| Some (Pvc_constraint { locally_abstract_univars = vars; typ })
->
Some
( label
~space:true
(* TODO: This isn't a correct use of sep! It ruins how *
comments are interleaved. *)
(makeList
[ makeList
~sep:(Sep " ")
(atom "type"
:: List.map ~f:(fun v -> atom v.txt) vars)
; atom "."
])
(self#core_type typ)
, `Constraint )
| Some (Pvc_coercion { ground; coercion }) ->
Some
( self#core_type coercion
, `Coercion
(match ground with
| Some ground -> Some (self#core_type ground)
| None -> None) )
| None -> None
in
match pat.ppat_attributes, pat.ppat_desc with
| [], Ppat_var _ ->
self#wrappedBinding
prefixText
~arrow:"=>"
(source_map ~loc:pat.ppat_loc (self#simple_pattern pat))
?vbct
[]
expr
(* Ppat_constraint is used in bindings of the form * * let
(inParenVar:typ) = ... * * And in the case of let bindings for
explicitly polymorphic type * annotations (see parser for more
details). * * See reason_parser.mly for explanation of how we
encode the two primary * forms of explicit polymorphic
annotations in the parse tree, and how * we must recover them
here. *)
| [], Ppat_open (lid, { ppat_desc = Ppat_record (l, closed); _ }) ->
(* Special case handling for:
*
* let Foo.{
* destruct1,
* destruct2,
* destruct3,
* destruct4,
* destruct5,
* } = bar;
*)
let upUntilEqual =
let pat = self#patternRecord l closed in
label
(label
~space:true
(atom prefixText)
(label (self#longident_loc lid) (atom ".")))
pat
in
let appTerms = self#unparseExprApplicationItems expr in
let includingEqual =
let vbct =
match vbct with
| Some (x, `Constraint) -> [ formatJustTheTypeConstraint x ]
| Some (x, `Coercion ground) -> [ formatJustCoerce ground x ]
| None -> []
in
makeList ~postSpace:true ((upUntilEqual :: vbct) @ [ atom "=" ])
in
formatAttachmentApplication
applicationFinalWrapping
(Some (true, includingEqual))
appTerms
| [], Ppat_constraint (p, ty) ->
(* Locally abstract forall types are *seriously* mangled by the parsing
* stage, and we have to be very smart about how to recover it.
*
* let df_locallyAbstractFuncAnnotated:
* type a b.
* a =>
* b =>
* (inputEchoRecord a, inputEchoRecord b) =
* fun (input: a) (input2: b) => (
* {inputIs: input},
* {inputIs: input2}
* );
*
* becomes:
*
* let df_locallyAbstractFuncAnnotatedTwo:
* 'a 'b .
* 'a => 'b => (inputEchoRecord 'a, inputEchoRecord 'b)
* =
* fun (type a) (type b) => (
* fun (input: a) (input2: b) => ({inputIs: input}, {inputIs:input2}):
* a => b => (inputEchoRecord a, inputEchoRecord b)
* );
*)
let layoutPattern =
source_map ~loc:pat.ppat_loc (self#simple_pattern p)
in
let leadingAbsTypesAndExpr =
self#leadingCurriedAbstractTypes expr
in
(match p.ppat_desc, ty.ptyp_desc, leadingAbsTypesAndExpr with
| ( Ppat_var _
, Ptyp_poly (typeVars, varifiedPolyType)
, ( (_ :: _ as absVars)
, Pexp_constraint (funWithNewTypes, nonVarifiedExprType) ) )
when self#isRenderableAsPolymorphicAbstractTypes
typeVars
(* If even artificially varified - don't know until
returns*)
varifiedPolyType
absVars
nonVarifiedExprType ->
(* We assume was the case whenever we see this pattern in the *
AST, it was because the parser parsed the polymorphic locally
* abstract type sugar. * *
Ppat_var..Ptyp_poly...Pexp_constraint: * * let x: 'a 'b . 'a
=> 'b => 'b = * fun (type a) (type b) => * (fun aVal bVal =>
bVal : a => b => b); * * We need to be careful not to
accidentally detect similar * forms, that cannot be printed
as sugar. * * let x: 'a 'b . 'a => 'b => 'b = * fun (type a)
(type b) => * (fun aVal bVal => bVal : int => int => int); *
* Should *NOT* be formatted as: * * let x: type a b. int =>
int => int = fun aVal bVal => bVal; * * The helper function *
[same_ast_modulo_varification_and_extensions] was created to
* help compare the varified constraint pattern body, and the
* non-varified expression constraint type. * * The second
requirement that we check before assuming that the * sugar
form is correct, is to make sure the list of type vars *
corresponds to a leading prefix of the Pexp_newtype
variables. *)
self#locallyAbstractPolymorphicFunctionBinding
prefixText
layoutPattern
funWithNewTypes
absVars
nonVarifiedExprType
| _ ->
let typeLayout, layoutPattern =
let typeLayout =
source_map ~loc:ty.ptyp_loc (self#core_type ty)
in
match vbct with
| Some _ ->
(* nested constraints *)
( vbct
, makeList
~wrap:("(", ")")
[ layoutPattern
; formatJustTheTypeConstraint typeLayout
] )
| None -> Some (typeLayout, `Constraint), layoutPattern
in
let appTerms = self#unparseExprApplicationItems expr in
self#formatSimplePatternBinding
~wrap:true
prefixText
layoutPattern
typeLayout
appTerms)
| _ ->
let layoutPattern =
source_map
~loc:pat.ppat_loc
(match vbct with
| Some _ ->
(match pat.ppat_desc with
| Ppat_alias _ ->
makeList
~wrap:("(", ")")
[ self#pattern_with_precedence
~attrs:pat.ppat_attributes
pat
]
| _ ->
self#pattern_with_precedence
~attrs:pat.ppat_attributes
pat)
| None -> self#pattern pat)
in
let appTerms = self#unparseExprApplicationItems expr in
self#formatSimplePatternBinding
prefixText
layoutPattern
vbct
appTerms
in
let { Reason_attributes.stdAttrs; docAttrs; _ } =
Reason_attributes.partitionAttributes ~partDoc:true attrs
in
let body = makeList ~inline:(true, true) [ body ] in
let layout =
self#attach_std_item_attrs stdAttrs (source_map ~loc body)
in
self#attachDocAttrsToLayout
~stdAttrs
~docAttrs
~loc:pat.ppat_loc
~layout
()
(* Ensures that the constraint is formatted properly for sake of
function binding (formatted without arrows) let x y z :
no_unguarded_arrows_allowed_here => ret; *)
method normalizeFunctionArgsConstraint argsList return =
match return.pexp_desc with
| Pexp_constraint (e, ct) ->
let typeLayout =
source_map
~loc:ct.ptyp_loc
(self#non_arrowed_non_simple_core_type ct)
in
( [ makeList
~break:IfNeed
~inline:(true, true)
(argsList @ [ formatJustTheTypeConstraint typeLayout ])
]
, e )
| _ -> argsList, return
method normalizeConstructorArgsConstraint argsList return =
match return.pcl_desc with
| Pcl_constraint (e, ct) when return.pcl_attributes == [] ->
let typeLayout =
source_map
~loc:ct.pcty_loc
(self#non_arrowed_class_constructor_type ct)
in
argsList @ [ formatJustTheTypeConstraint typeLayout ], e
| _ -> argsList, return
method bindingsLocationRange ?extension l =
let len = List.length l in
let fstLoc =
match extension with
| Some ({ pexp_loc = { loc_ghost = false; _ }; _ } as ext) ->
ext.pexp_loc
| _ -> (List.nth l 0).pvb_loc
in
let lstLoc = (List.nth l (len - 1)).pvb_loc in
{ loc_start = fstLoc.loc_start
; loc_end = lstLoc.loc_end
; loc_ghost = false
}
method bindingOpsLocationRange { let_; ands; _ } =
let fstLoc = let_.pbop_loc in
let lstLoc =
match ands with
| [] -> fstLoc
| xs ->
let len = List.length xs in
(List.nth xs (len - 1)).pbop_loc
in
{ loc_start = fstLoc.loc_start
; loc_end = lstLoc.loc_end
; loc_ghost = false
}
method bindings ?extension (rf, l) =
let label = add_extension_sugar "let" extension in
let label =
match rf with Nonrecursive -> label | Recursive -> label ^ " rec"
in
match l with
| [ x ] -> self#value_binding label x
| l ->
let items =
List.mapi
~f:(fun i x ->
let loc = extractLocValBinding x in
let layout =
self#value_binding (if i == 0 then label else "and") x
in
loc, layout)
l
in
let itemsLayout =
groupAndPrint
~xf:(fun (_, layout) -> layout)
~getLoc:(fun (loc, _) -> loc)
~comments:self#comments
items
in
makeList
~postSpace:true
~break:Always
~indent:0
~inline:(true, true)
itemsLayout
method letop_bindings { let_; ands; _ } =
let label =
Reason_syntax_util.compress_letop_identifier let_.pbop_op.txt
in
let let_item = self#binding_op label let_ in
match ands with
| [] -> let_item
| l ->
let and_items =
List.map
~f:(fun x ->
let loc = extractLocBindingOp x in
let layout =
self#binding_op
(Reason_syntax_util.compress_letop_identifier
x.pbop_op.txt)
x
in
loc, layout)
l
in
let itemsLayout =
groupAndPrint
~xf:(fun (_, layout) -> layout)
~getLoc:(fun (loc, _) -> loc)
~comments:self#comments
((extractLocBindingOp let_, let_item) :: and_items)
in
makeList
~postSpace:true
~break:Always
~indent:0
~inline:(true, true)
itemsLayout
method pexp_open ~attrs ?extension expr me =
let openLayout =
label
~space:true
(atom
(add_open_extension_sugar
~override:me.popen_override
extension))
(self#moduleExpressionToFormattedApplicationItems me.popen_expr)
in
let attrsOnOpen =
makeList
~inline:(true, true)
~postSpace:true
~break:Always
(self#attributes attrs @ [ openLayout ])
in
(* Just like the bindings, have to synthesize a location since the *
Pexp location is parsed (potentially) beginning with the open *
brace {} in the let sequence. *)
let layout = source_map ~loc:me.popen_loc attrsOnOpen in
let loc =
{ me.popen_loc with
loc_start =
{ me.popen_loc.loc_start with
pos_lnum = expr.pexp_loc.loc_start.pos_lnum
}
}
in
loc, layout
method letList expr =
let letModuleBinding ?extension s me =
let prefixText = add_extension_sugar "module" extension in
let bindingName = atom ~loc:s.loc (moduleIdent s) in
let moduleExpr = me in
let letModuleLayout =
self#let_module_binding prefixText bindingName moduleExpr
in
let letModuleLoc =
{ loc_start = s.loc.loc_start
; loc_end = me.pmod_loc.loc_end
; loc_ghost = false
}
in
(* Just like the bindings, have to synthesize a location since the
* Pexp location is parsed (potentially) beginning with the open
* brace {} in the let sequence. *)
let layout = source_map ~loc:letModuleLoc letModuleLayout in
let _, return =
self#curriedFunctorPatternsAndReturnStruct moduleExpr
in
let loc = { letModuleLoc with loc_end = return.pmod_loc.loc_end } in
loc, layout
in
(* Recursively transform a nested ast of "let-items", into a flat *
list containing the location indicating start/end of the "let-item"
and * its layout. *)
let rec processLetList acc expr =
let { Reason_attributes.stdAttrs
; arityAttrs
; jsxAttrs
; stylisticAttrs
; _
}
=
Reason_attributes.partitionAttributes
~allowUncurry:false
expr.pexp_attributes
in
match stdAttrs, expr.pexp_desc with
| [], Pexp_let (rf, l, e) ->
(* For "letList" bindings, the start/end isn't as simple as with
* module value bindings. For "let lists", the sequences were formed
* within braces {}. The parser relocates the first let binding to the
* first brace. *)
let bindingsLayout = self#bindings (rf, l) in
let bindingsLoc = self#bindingsLocationRange l in
let layout = source_map ~loc:bindingsLoc bindingsLayout in
processLetList ((bindingsLoc, layout) :: acc) e
| attrs, Pexp_letop ({ body; _ } as op) ->
(* For "letList" bindings, the start/end isn't as simple as with
* module value bindings. For "let lists", the sequences were formed
* within braces {}. The parser relocates the first let binding to the
* first brace. *)
let bindingsLayout = self#letop_bindings op in
let bindingsLoc = self#bindingOpsLocationRange op in
let bindingsLayout =
makeList
~break:IfNeed
~inline:(true, true)
~postSpace:true
(self#attributes attrs @ [ bindingsLayout ])
in
let layout = source_map ~loc:bindingsLoc bindingsLayout in
processLetList ((bindingsLoc, layout) :: acc) body
| attrs, Pexp_open (me, e)
(* Add this when check to make sure these are handled as regular
"simple expressions" *)
when not
(self#isSeriesOfOpensFollowedByNonSequencyExpression
{ expr with pexp_attributes = [] }) ->
if Reason_attributes.has_open_notation_attr stylisticAttrs
then
( Location.none
, label
(label
(self#moduleExpressionToFormattedApplicationItems
me.popen_expr)
(atom "."))
(makeLetSequence ~wrap:("(", ")") (self#letList e)) )
:: acc
else
let loc, layout = self#pexp_open ~attrs expr me in
processLetList ((loc, layout) :: acc) e
| [], Pexp_letmodule (s, me, e) ->
let loc, layout = letModuleBinding s me in
processLetList ((loc, layout) :: acc) e
| [], Pexp_letexception (extensionConstructor, expr) ->
let exc = self#exception_declaration extensionConstructor in
let layout = source_map ~loc:extensionConstructor.pext_loc exc in
processLetList
((extensionConstructor.pext_loc, layout) :: acc)
expr
| [], Pexp_sequence (({ pexp_desc = Pexp_sequence _; _ } as e1), e2)
| [], Pexp_sequence (({ pexp_desc = Pexp_let _; _ } as e1), e2)
| [], Pexp_sequence (({ pexp_desc = Pexp_open _; _ } as e1), e2)
| [], Pexp_sequence (({ pexp_desc = Pexp_letmodule _; _ } as e1), e2)
| [], Pexp_sequence (e1, e2) ->
let e1Layout =
match expression_not_immediate_extension_sugar e1 with
| Some (extension, e) ->
self#attach_std_item_attrs ~extension [] (self#unparseExpr e)
| None -> self#unparseExpr e1
in
let loc = e1.pexp_loc in
let layout = source_map ~loc e1Layout in
processLetList ((loc, layout) :: acc) e2
| _ ->
let expr =
{ expr with pexp_attributes = arityAttrs @ stdAttrs @ jsxAttrs }
in
(match expression_not_immediate_extension_sugar expr with
| Some
( extension
, { pexp_attributes = []; pexp_desc = Pexp_let (rf, l, e); _ }
) ->
let bindingsLayout = self#bindings ~extension (rf, l) in
let bindingsLoc =
self#bindingsLocationRange ~extension:expr l
in
let layout = source_map ~loc:bindingsLoc bindingsLayout in
processLetList
((extractLocationFromValBindList expr l, layout) :: acc)
e
| Some
( extension
, { pexp_attributes = []
; pexp_desc = Pexp_letmodule (s, me, e)
; _
} ) ->
let loc, layout = letModuleBinding ~extension s me in
processLetList ((loc, layout) :: acc) e
| Some
( extension
, { pexp_attributes = attrs
; pexp_desc = Pexp_open (me, e)
; _
} ) ->
let loc, layout = self#pexp_open ~attrs ~extension expr me in
processLetList ((loc, layout) :: acc) e
| Some (extension, e) ->
let layout =
self#attach_std_item_attrs ~extension [] (self#unparseExpr e)
in
(expr.pexp_loc, layout) :: acc
| None ->
(* Should really do something to prevent infinite loops here.
Never allowing a top level call into letList to recurse back
to self#unparseExpr- top level calls into letList *must* be
one of the special forms above whereas lower level recursive
calls may be of any form. *)
let layout =
source_map ~loc:expr.pexp_loc (self#unparseExpr expr)
in
(expr.pexp_loc, layout) :: acc)
in
let es = processLetList [] expr in
(* Interleave whitespace between the "let-items" when appropriate *)
groupAndPrint
~xf:(fun (_, layout) -> layout)
~getLoc:(fun (loc, _) -> loc)
~comments:self#comments
(List.rev es)
method constructor_expression
?(polyVariant = false)
~arityIsClear
stdAttrs
ctor
eo =
let implicit_arity, arguments =
match eo.pexp_desc with
| Pexp_construct ({ txt = Lident "()"; _ }, _) ->
(* `foo() is a polymorphic variant that contains a single unit
construct as expression * This requires special formatting:
`foo(()) -> `foo() *)
false, atom "()"
(* special printing: MyConstructor(()) -> MyConstructor() *)
| Pexp_tuple l when is_single_unit_construct l -> false, atom "()"
| Pexp_tuple l when polyVariant == true ->
false, self#unparseSequence ~wrap:("(", ")") ~construct:`Tuple l
| Pexp_tuple l ->
(* There is no ambiguity when the number of tuple components is 1.
We don't need put implicit_arity in that case *)
(match l with
| exprList when isSingleArgParenApplication exprList ->
false, self#singleArgParenApplication exprList
| _ ->
( not arityIsClear
, makeTup (List.map ~f:self#unparseProtectedExpr l) ))
| _ when isSingleArgParenApplication [ eo ] ->
false, self#singleArgParenApplication [ eo ]
| _ -> false, makeTup [ self#unparseProtectedExpr eo ]
in
let arguments = source_map ~loc:eo.pexp_loc arguments in
let construction =
label
ctor
(if isSequencey arguments
then arguments
else ensureSingleTokenSticksToLabel arguments)
in
let attrs =
if implicit_arity && not polyVariant
then
{ attr_name = { txt = "implicit_arity"; loc = eo.pexp_loc }
; attr_payload = PStr []
; attr_loc = eo.pexp_loc
}
:: stdAttrs
else stdAttrs
in
match attrs with
| [] -> construction
| _ :: _ -> formatAttributed construction (self#attributes attrs)
(* TODOATTRIBUTES: Handle stdAttrs here (merge with implicit_arity) *)
method constructor_pattern ?(polyVariant = false) ~arityIsClear ctor po
=
let implicit_arity, arguments =
match po.ppat_desc with
(* There is no ambiguity when the number of tuple components is 1.
We don't need put implicit_arity in that case *)
| Ppat_tuple (([] | _ :: []) as l) -> false, l
| Ppat_tuple l -> not arityIsClear, l
| _ -> false, [ po ]
in
let space, arguments =
match arguments with
| [ x ] when is_direct_pattern x -> true, self#simple_pattern x
| xs when isSingleArgParenPattern xs ->
false, self#singleArgParenPattern xs
(* Optimize the case when it's a variant holding a shot variable -
avoid trailing*)
| [ ({ ppat_desc = Ppat_constant (Pconst_string (s, _, None)); _ }
as x)
]
| [ ({ ppat_desc = Ppat_construct ({ txt = Lident s; _ }, None); _ }
as x)
]
| [ ({ ppat_desc = Ppat_var { txt = s; _ }; _ } as x) ]
when Reason_heuristics.singleTokenPatternOmmitTrail s ->
let layout = makeTup ~trailComma:false [ self#pattern x ] in
false, source_map ~loc:po.ppat_loc layout
| [ ({ ppat_desc = Ppat_any; _ } as x) ]
| [ ({ ppat_desc = Ppat_constant (Pconst_char _); _ } as x) ]
| [ ({ ppat_desc = Ppat_constant (Pconst_integer _); _ } as x) ] ->
let layout = makeTup ~trailComma:false [ self#pattern x ] in
false, source_map ~loc:po.ppat_loc layout
| xs ->
let layout = makeTup (List.map ~f:self#pattern xs) in
false, source_map ~loc:po.ppat_loc layout
in
let construction = label ~space ctor arguments in
if implicit_arity && not polyVariant
then
formatAttributed
construction
(self#attributes
[ { attr_name = { txt = "implicit_arity"; loc = po.ppat_loc }
; attr_payload = PStr []
; attr_loc = po.ppat_loc
}
])
else construction
(* Provides special printing for constructor arguments:
* iff there's one argument & they have some kind of wrapping,
* they're wrapping need to 'hug' the surrounding parens.
* Example:
* switch x {
* | Some({
* a,
* b,
* }) => ()
* }
*
* Notice how ({ and }) hug.
* This applies for records, arrays, tuples & lists.
* Also see `isSingleArgParenPattern` to determine if this kind of wrapping applies.
*)
method singleArgParenPattern =
function
| [ { ppat_desc = Ppat_record (l, closed); ppat_loc = loc; _ } ] ->
source_map ~loc (self#patternRecord ~wrap:("(", ")") l closed)
| [ { ppat_desc = Ppat_array l; ppat_loc = loc; _ } ] ->
source_map ~loc (self#patternArray ~wrap:("(", ")") l)
| [ { ppat_desc = Ppat_tuple l; ppat_loc = loc; _ } ] ->
source_map ~loc (self#patternTuple ~wrap:("(", ")") l)
| [ ({ ppat_desc = Ppat_construct ({ txt = Lident "::"; _ }, _)
; ppat_loc
; _
} as listPattern)
] ->
source_map
~loc:ppat_loc
(self#patternList ~wrap:("(", ")") listPattern)
| _ -> assert false
(* TODO: Similar to tuples, do not print parens around type constraints
(same for lists) *)
method patternArray ?(wrap = "", "") l =
let left, right = wrap in
let wrap = left ^ "[|", "|]" ^ right in
makeList
~wrap
~break:IfNeed
~postSpace:true
~sep:commaTrail
(List.map ~f:self#pattern l)
method patternTuple ?(wrap = "", "") l =
let left, right = wrap in
let wrap = left ^ "(", ")" ^ right in
makeList
~wrap
~sep:commaTrail
~postSpace:true
~break:IfNeed
(List.map ~f:self#pattern l)
method patternRecord ?(wrap = "", "") l closed =
let longident_x_pattern (li, p) =
match li, p.ppat_desc with
| { txt = ident; _ }, Ppat_var { txt; _ }
when Longident.last_exn ident = txt ->
(* record field punning when destructuring. {x: x, y: y} becomes {x, y} *)
(* works with module prefix too: {MyModule.x: x, y: y} becomes {MyModule.x, y} *)
self#longident_loc li
| ( { txt = ident; _ }
, Ppat_alias
( { ppat_desc = Ppat_var { txt = ident2; _ }; _ }
, { txt = aliasIdent; _ } ) )
when Longident.last_exn ident = ident2 ->
(* record field punning when destructuring with renaming. {state:
state as prevState} becomes {state as prevState *)
(* works with module prefix too: {ReasonReact.state: state as
prevState} becomes {ReasonReact.state as prevState *)
makeList
~sep:(Sep " ")
[ self#longident_loc li; atom "as"; atom aliasIdent ]
| _ ->
let pattern =
let formatted = self#pattern p in
let wrap =
match p.ppat_desc with
| Ppat_constraint (_, _) -> Some ("(", ")")
| _ -> None
in
makeList ~inline:(true, true) ?wrap [ formatted ]
in
label
~space:true
(makeList [ self#longident_loc li; atom ":" ])
pattern
in
let rows =
List.map ~f:longident_x_pattern l
@ match closed with Closed -> [] | _ -> [ atom "_" ]
in
let left, right = wrap in
let wrap = left ^ "{", "}" ^ right in
makeList
~wrap
~break:IfNeed
~sep:commaTrail
~pad:(true, true)
~postSpace:true
rows
method patternFunction ?extension loc l =
let estimatedFunLocation =
{ loc_start = loc.loc_start
; loc_end =
{ loc.loc_start with
pos_cnum = loc.loc_start.Lexing.pos_cnum + 3
}
; loc_ghost = false
}
in
makeList
~postSpace:true
~break:IfNeed
~inline:(true, true)
~pad:(false, false)
(atom
~loc:estimatedFunLocation
(add_extension_sugar funToken extension)
:: self#case_list l)
method parenthesized_expr ?break expr =
let result = self#unparseExpr expr in
match expr.pexp_attributes, expr.pexp_desc with
| [], (Pexp_tuple _ | Pexp_construct ({ txt = Lident "()"; _ }, None))
->
result
| _ -> makeList ~wrap:("(", ")") ?break [ self#unparseExpr expr ]
(* Expressions requiring parens, in most contexts such as separated by
infix *)
method expression_requiring_parens_in_infix x =
let { Reason_attributes.stdAttrs; _ } =
Reason_attributes.partitionAttributes x.pexp_attributes
in
assert (stdAttrs == []);
(* keep the incoming expression around, an expr with * immediate
extension sugar might contain less than perfect location * info in
its children (used for comment interleaving), the expression passed
to * 'expression_requiring_parens_in_infix' contains the correct
location *)
let originalExpr = x in
let extension, x = expression_immediate_extension_sugar x in
match x.pexp_desc with
(* The only reason Pexp_fun must also be wrapped in parens when under
pipe, is that its => token will be confused with the match token.
Simple expression will also invoke `#reset`. *)
| Pexp_function (_, _, Pfunction_cases _) when pipe || semi ->
None (* Would be rendered as simplest_expression *)
(* Pexp_function, on the other hand, doesn't need wrapping in parens
in most cases anymore, since `fun` is not ambiguous anymore (we
print Pexp_fun as ES6 functions). *)
| Pexp_function (_, _, Pfunction_cases (cases, loc, _attrs)) ->
let prec = Custom funToken in
let expr = self#patternFunction ?extension loc cases in
Some
(SpecificInfixPrecedence
( { reducePrecedence = prec; shiftPrecedence = prec }
, LayoutNode expr ))
| _ ->
(* The Pexp_function cases above don't use location because comment
printing breaks for them. *)
let itm =
match x.pexp_desc with
| Pexp_function (_ :: _, _, Pfunction_body _) | Pexp_newtype _ ->
(* let uncurried = *)
let args, ret = self#curriedPatternsAndReturnVal x in
(match args with
| [] -> raise (NotPossible "no arrow args in unparse ")
| firstArg :: tl ->
(* Suboptimal printing of parens: * * something >>= fun x => x
\+ 1; * * Will be printed as: * * something >>= (fun x => x
\+ 1); * * Because the arrow has lower precedence than >>=,
but it wasn't * needed because * * (something >>= fun x) =>
x + 1; * * Is not a valid parse. Parens around the `=>`
weren't needed to * prevent reducing instead of shifting.
To optimize this part, we need * a much deeper encoding of
the parse rules to print parens only when * needed, testing
which rules will be reduced. It really should be *
integrated deeply with Menhir. * * One question is, if it's
this difficult to describe when parens are * needed, should
we even print them with the minimum amount? We can *
instead model everything as "infix" with ranked
precedences. *)
let retValUnparsed = self#unparseExprApplicationItems ret in
Some
(self#wrapCurriedFunctionBinding
~sweet:(extension = None)
(add_extension_sugar funToken extension)
~arrow:"=>"
firstArg
tl
retValUnparsed))
| Pexp_try (e, l) ->
let estimatedBracePoint =
{ loc_start = e.pexp_loc.loc_end
; loc_end = x.pexp_loc.loc_end
; loc_ghost = false
}
in
let cases =
self#case_list ~allowUnguardedSequenceBodies:true l
in
let switchWith =
self#dont_preserve_braces#formatSingleArgLabelApplication
(atom (add_extension_sugar "try" extension))
e
in
Some
(label
~space:true
switchWith
(source_map
~loc:estimatedBracePoint
(makeList
~indent:settings.trySwitchIndent
~wrap:("{", "}")
~break:Always_rec
~postSpace:true
cases)))
(* These should have already been handled and we should never
havgotten this far. *)
| Pexp_setinstvar _ ->
raise
(Invalid_argument
"Cannot handle setinstvar here - call unparseExpr")
| Pexp_setfield (_, _, _) ->
raise
(Invalid_argument
"Cannot handle setfield here - call unparseExpr")
| Pexp_apply _ ->
raise
(Invalid_argument
"Cannot handle apply here - call unparseExpr")
| Pexp_match (e, l) ->
let estimatedBracePoint =
{ loc_start = e.pexp_loc.loc_end
; (* See originalExpr binding, for more info. * It contains
the correct location under immediate extension sugar *)
loc_end = originalExpr.pexp_loc.loc_end
; loc_ghost = false
}
in
let cases =
self#case_list ~allowUnguardedSequenceBodies:true l
in
let switchWith =
label
~space:true
(atom (add_extension_sugar "switch" extension))
(self#parenthesized_expr ~break:IfNeed e)
in
let lbl =
label
~space:true
switchWith
(source_map
~loc:estimatedBracePoint
(makeList
~indent:settings.trySwitchIndent
~wrap:("{", "}")
~break:Always_rec
~postSpace:true
cases))
in
Some lbl
| Pexp_ifthenelse (e1, e2, eo) ->
let blocks, finalExpression = sequentialIfBlocks eo in
let rec singleExpression exp =
match exp.pexp_desc with
| Pexp_ident _ -> true
| Pexp_constant _ -> true
| Pexp_construct (_, arg) ->
(match arg with
| None -> true
| Some x -> singleExpression x)
| _ -> false
in
let singleLineIf =
singleExpression e1
&& singleExpression e2
&&
match eo with
| Some expr -> singleExpression expr
| None -> true
in
let makeLetSequence =
if singleLineIf
then makeLetSequenceSingleLine
else makeLetSequence
in
let rec sequence soFar remaining =
match remaining, finalExpression with
| [], None -> soFar
| [], Some e ->
let soFarWithElseAppended =
makeList ~postSpace:true [ soFar; atom "else" ]
in
label
~space:true
soFarWithElseAppended
(source_map
~loc:e.pexp_loc
(makeLetSequence (self#letList e)))
| hd :: tl, _ ->
let e1, e2 = hd in
let soFarWithElseIfAppended =
label
~space:true
(makeList ~postSpace:true [ soFar; atom "else if" ])
(makeList ~wrap:("(", ")") [ self#unparseExpr e1 ])
in
let nextSoFar =
label
~space:true
soFarWithElseIfAppended
(source_map
~loc:e2.pexp_loc
(makeLetSequence (self#letList e2)))
in
sequence nextSoFar tl
in
let init =
let if_ = atom (add_extension_sugar "if" extension) in
let cond = self#parenthesized_expr e1 in
label
~space:true
(source_map ~loc:e1.pexp_loc (label ~space:true if_ cond))
(source_map
~loc:e2.pexp_loc
(makeLetSequence (self#letList e2)))
in
Some (sequence init blocks)
| Pexp_while (e1, e2) ->
let lbl =
let while_ = atom (add_extension_sugar "while" extension) in
let cond = self#parenthesized_expr e1 in
label
~space:true
(label ~space:true while_ cond)
(source_map
~loc:e2.pexp_loc
(makeLetSequence (self#letList e2)))
in
Some lbl
| Pexp_for (s, e1, e2, df, e3) ->
(* for longIdentifier in
* (longInit expr) to
* (longEnd expr) {
* print_int longIdentifier;
* };
*)
let identifierIn =
makeList ~postSpace:true [ self#pattern s; atom "in" ]
in
let dockedToFor =
makeList
~break:IfNeed
~postSpace:true
~inline:(true, true)
~wrap:("(", ")")
[ identifierIn
; makeList
~postSpace:true
[ self#unparseExpr e1; self#direction_flag df ]
; self#unparseExpr e2
]
in
let upToBody =
makeList
~inline:(true, true)
~postSpace:true
[ atom (add_extension_sugar "for" extension); dockedToFor ]
in
Some
(label
~space:true
upToBody
(source_map
~loc:e3.pexp_loc
(makeLetSequence (self#letList e3))))
| Pexp_new li ->
Some
(label
~space:true
(atom "new")
(self#longident_class_or_type_loc li))
| Pexp_assert e ->
Some (label (atom "assert") (makeTup [ self#unparseExpr e ]))
| Pexp_lazy e ->
Some (self#formatSingleArgLabelApplication (atom "lazy") e)
| Pexp_poly _ ->
failwith
("This version of the pretty printer assumes it is \
impossible to "
^ "construct a Pexp_poly outside of a method definition - \
yet it sees one.")
| _ -> None
in
(match itm with
| None -> None
| Some i ->
Some (PotentiallyLowPrecedence (source_map ~loc:x.pexp_loc i)))
method potentiallyConstrainedExpr x =
match x.pexp_desc with
| Pexp_constraint (e, ct) ->
formatTypeConstraint (self#unparseExpr e) (self#core_type ct)
| _ -> self#unparseExpr x
(* Because the rule BANG simple_expr was given %prec below_DOT_AND_SHARP,
* !x.y.z will parse as !(x.y.z) and not (!x).y.z.
*
* !x.y.z == !((x.y).z)
* !x#y#z == !((x#y)#z)
*
* So the intuition is: In general, any simple expression can exist to the
* left of a `.`, except `BANG simple_expr`, which has special precedence,
* and must be guarded in this one case.
*
* TODO: Instead of special casing this here, we should continue to extend
* unparseExpr to also unparse simple expressions, (by encoding the
* rules precedence below_DOT_AND_SHARP).
*
* TODO:
* Some would even have the prefix application be parsed with lower
* precedence function *application*. In the case of !, where ! means not,
* it makes a lot of sense because (!identifier)(arg) would be meaningless.
*
* !callTheFunction(1, 2, 3)(andEvenCurriedArgs)
*
* Only problem is that it could then not appear anywhere simple expressions
* would appear.
*
* We could make a special case for ! followed by one simple expression, and
* consider the result simple.
*
* Alternatively, we can figure out a way to not require simple expressions
* in the most common locations such as if/while tests. This is really hard
* (impossible w/ grammars Menhir supports?)
*
* if ! myFunc argOne argTwo {
*
* } else {
*
* };
*
*)
method simple_enough_to_be_lhs_dot_send x =
match x.pexp_desc with
| Pexp_apply (eFun, _) ->
(match printedStringAndFixityExpr eFun with
| AlmostSimplePrefix _ | UnaryPlusPrefix _ | UnaryMinusPrefix _
| UnaryNotPrefix _ | UnaryPostfix _ | Infix _ ->
self#simplifyUnparseExpr x
| Letop _ | Andop _ | Normal ->
if x.pexp_attributes == []
then
(* `let a = foo().bar` instead of `let a = (foo()).bar *)
(* same for foo()##bar, foo()#=bar, etc. *)
self#unparseExpr x
else self#simplifyUnparseExpr x)
| _ -> self#simplifyUnparseExpr x
method unparseRecord
?wrap:(lwrap, rwrap = "", "")
?(withStringKeys = false)
?(allowPunning = true)
?(forceBreak = false)
l
eo =
(* forceBreak is a ref which can be set to always break the record
rows. * Example, when we have a row which contains a nested record,
* this ref can be set to true from inside the printing of that row,
* which forces breaks for the outer record structure. *)
let forceBreak = ref forceBreak in
let quote = atom "\"" in
let maybeQuoteFirstElem fst rest =
if withStringKeys
then
match fst.txt with
| Lident s -> quote :: atom s :: quote :: rest
| Ldot _ | Lapply _ -> assert false
else self#longident_loc fst :: rest
in
let makeRow (li, e) shouldPun =
let totalRowLoc =
{ loc_start = li.Asttypes.loc.loc_start
; loc_end = e.pexp_loc.loc_end
; loc_ghost = false
}
in
let stdAttrs =
Reason_attributes.extractStdAttrs e.pexp_attributes
in
let theRow =
match e.pexp_desc, shouldPun, allowPunning with
(* record value punning. Turns {foo: foo, bar: 1} into {foo, bar: 1} *)
(* also turns {Foo.bar: bar, baz: 1} into {Foo.bar, baz: 1} *)
(* don't turn {bar: [@foo] bar, baz: 1} into {bar, baz: 1} *)
(* don't turn {bar: Foo.bar, baz: 1} into {bar, baz: 1}, naturally *)
| Pexp_ident { txt = Lident value; _ }, true, true
when Longident.last_exn li.txt = value && stdAttrs = [] ->
makeList (maybeQuoteFirstElem li [])
(* Force breaks for nested records or mel.obj sugar
* Example:
* let person = {name: {first: "Bob", last: "Zhmith"}, age: 32};
* is a lot less readable than
* let person = {
* "name": {
* "first": "Bob",
* "last": "Zhmith"
* },
* "age": 32
* };
*)
| Pexp_record (recordRows, optionalGadt), _, _ ->
forceBreak := true;
let keyWithColon =
makeList (maybeQuoteFirstElem li [ atom ":" ])
in
let value =
self#unparseRecord ~forceBreak:true recordRows optionalGadt
in
label ~space:true keyWithColon value
| Pexp_extension (s, p), _, _ when s.txt = "mel.obj" ->
forceBreak := true;
let keyWithColon =
makeList (maybeQuoteFirstElem li [ atom ":" ])
in
let value =
self#formatMelObjExtensionSugar ~forceBreak:true p
in
label ~space:true keyWithColon value
| Pexp_object classStructure, _, _ ->
forceBreak := true;
let keyWithColon =
makeList (maybeQuoteFirstElem li [ atom ":" ])
in
let value =
self#classStructure ~forceBreak:true classStructure
in
label ~space:true keyWithColon value
| _ ->
let argsList, return = self#curriedPatternsAndReturnVal e in
(match argsList with
| [] ->
let appTerms = self#unparseExprApplicationItems e in
let upToColon =
makeList (maybeQuoteFirstElem li [ atom ":" ])
in
formatAttachmentApplication
applicationFinalWrapping
(Some (true, upToColon))
appTerms
| firstArg :: tl ->
let upToColon =
makeList (maybeQuoteFirstElem li [ atom ":" ])
in
let returnedAppTerms =
self#unparseExprApplicationItems return
in
self#wrapCurriedFunctionBinding
~sweet:true
~attachTo:upToColon
funToken
~arrow:"=>"
firstArg
tl
returnedAppTerms)
in
source_map ~loc:totalRowLoc theRow, totalRowLoc
in
let rec getRows l =
match l with
| [] -> []
| hd :: [] -> [ makeRow hd true ]
| hd :: hd2 :: tl -> makeRow hd true :: getRows (hd2 :: tl)
in
let allRows =
match eo with
| None ->
(match l with
(* No punning (or comma) for records with only a single field.
It's ambiguous with an expression in a scope *)
(* See comment in parser.mly for
lbl_expr_list_with_at_least_one_non_punned_field *)
| [ hd ] -> [ makeRow hd false ]
| _ -> getRows l)
(* This case represents a "spread" being present -> {...x, a: 1, b:
2} *)
| Some withRecord ->
let firstRow =
let row =
(* Unclear why "sugar_expr" was special cased hre. *)
let appTerms = self#unparseExprApplicationItems withRecord in
formatAttachmentApplication
applicationFinalWrapping
(Some (false, atom "..."))
appTerms
in
source_map ~loc:withRecord.pexp_loc row, withRecord.pexp_loc
in
firstRow :: getRows l
in
let break =
(* if a record has more than 1 row, always break *)
match !forceBreak, allRows with
| false, ([] | [ _ ]) -> Layout.IfNeed
| _ -> Layout.Always_rec
in
makeList
~wrap:(lwrap ^ "{", "}" ^ rwrap)
~break
~sep:commaTrail
~pad:(true, true)
~postSpace:true
(groupAndPrint ~xf:fst ~getLoc:snd ~comments:self#comments allRows)
method isSeriesOfOpensFollowedByNonSequencyExpression expr =
match expr.pexp_attributes, expr.pexp_desc with
| [], Pexp_let _ -> false
| [], Pexp_letop _ -> false
| [], Pexp_sequence _ -> false
| [], Pexp_letmodule _ -> false
| ( []
, Pexp_open
( { popen_override
; popen_expr = { pmod_desc = Pmod_ident _; _ }
; _
}
, e ) ) ->
popen_override == Fresh
&& self#isSeriesOfOpensFollowedByNonSequencyExpression e
| [], Pexp_open _ -> false
| [], Pexp_letexception _ -> false
| [], Pexp_extension ({ txt; _ }, _) -> txt = "mel.obj"
| _ -> true
method unparseObject
?wrap:(lwrap, rwrap = "", "")
?(withStringKeys = false)
l
o =
let core_field_type { pof_desc; pof_attributes; _ } =
match pof_desc with
| Otag ({ txt; _ }, ct) ->
let l = Reason_attributes.extractStdAttrs pof_attributes in
let row =
let rowKey =
if withStringKeys
then makeList ~wrap:("\"", "\"") [ atom txt ]
else atom txt
in
label
~space:true
(makeList ~break:Layout.Never [ rowKey; atom ":" ])
(self#core_type ct)
in
(match l with
| [] -> row
| _ :: _ ->
makeList
~postSpace:true
~break:IfNeed
~inline:(true, true)
(List.concat [ self#attributes pof_attributes; [ row ] ]))
| Oinherit ct ->
makeList ~break:Layout.Never [ atom "..."; self#core_type ct ]
in
let rows = List.map ~f:core_field_type l in
let openness =
match o with Closed -> atom "." | Open -> atom ".."
in
(* if an object has more than 2 rows, always break for readability *)
let rows_layout =
let break, pad_right =
match rows with
| [] -> Layout.IfNeed, false
| [ _ ] -> Layout.IfNeed, true
| _ -> Layout.Always_rec, true
in
makeList
~break
~inline:(true, true)
~postSpace:true
~pad:(false, pad_right)
~sep:commaTrail
rows
in
makeList
~break:Layout.IfNeed
~preSpace:(rows != [])
~wrap:(lwrap ^ "{", "}" ^ rwrap)
(openness :: [ rows_layout ])
method unparseSequence ?(wrap = "", "") ~construct l =
match construct with
| `ES6List ->
let seq, ext =
match List.rev l with
| ext :: seq_rev -> List.rev seq_rev, ext
| [] -> assert false
in
makeES6List
~wrap
(List.map ~f:self#unparseExpr seq)
(self#unparseExpr ext)
| _ ->
let left, right = wrap in
let xf, (leftDelim, rightDelim) =
match construct with
| `List -> self#unparseExpr, ("[", "]")
| `Array -> self#unparseExpr, ("[|", "|]")
| `Tuple -> self#potentiallyConstrainedExpr, ("(", ")")
| `ES6List -> assert false
in
let wrap = left ^ leftDelim, rightDelim ^ right in
makeList
~wrap
~sep:commaTrail
~break:IfNeed
~postSpace:true
(List.map ~f:xf l)
method formatMelObjExtensionSugar
?(wrap = "", "")
?(forceBreak = false)
payload =
match payload with
| PStr [ itm ] ->
(match itm with
| { pstr_desc =
Pstr_eval ({ pexp_desc = Pexp_record (l, eo); _ }, [])
; _
} ->
self#unparseRecord
~forceBreak
~wrap
~withStringKeys:true
~allowPunning:false
l
eo
| { pstr_desc =
Pstr_eval
( { pexp_desc =
Pexp_extension ({ txt = "mel.obj"; _ }, payload)
; _
}
, [] )
; _
} ->
(* some folks write `[%mel.obj [%mel.obj {foo: bar}]]`. This looks
improbable but it happens often if you use the sugared version:
`[%mel.obj {"foo": bar}]`. We're gonna be lenient here and
treat it as if they wanted to just write `{"foo": bar}`.
Melange does the same relaxation when parsing mel.obj *)
self#formatMelObjExtensionSugar ~wrap ~forceBreak payload
| _ ->
raise
(Invalid_argument
"mel.obj only accepts a record. You've passed something else"))
| _ -> assert false
method should_preserve_requested_braces expr =
let { Reason_attributes.stylisticAttrs; _ } =
Reason_attributes.partitionAttributes expr.pexp_attributes
in
match expr.pexp_desc with
| Pexp_ifthenelse _ | Pexp_try _ -> false
| Pexp_sequence _ ->
(* `let ... in` should _always_ preserve braces *)
true
| _ ->
preserve_braces
&& Reason_attributes.has_preserve_braces_attrs stylisticAttrs
method simplest_expression x =
let { Reason_attributes.stdAttrs
; jsxAttrs
; stylisticAttrs
; arityAttrs
; _
}
=
Reason_attributes.partitionAttributes x.pexp_attributes
in
let hasJsxAttribute = jsxAttrs != [] in
if stdAttrs != []
then None
else if self#should_preserve_requested_braces x
then
let layout =
makeList
~break:(if inline_braces then Always else Always_rec)
~inline:(true, inline_braces)
~wrap:("{", "}")
~postSpace:true
~sep:(if inline_braces then Sep ";" else SepFinal (";", ";"))
(self#letList x)
in
Some layout
else
let item =
match x.pexp_desc with
(* The only reason Pexp_fun must also be wrapped in parens is that
its => token will be confused with the match token. *)
| Pexp_function (_ :: _, _, Pfunction_body _) when pipe || semi ->
Some (self#reset#simplifyUnparseExpr x)
| Pexp_function (_, _, Pfunction_cases (cases, loc, _attrs))
when pipe || semi ->
Some
(formatPrecedence
~loc:x.pexp_loc
(self#reset#patternFunction loc cases))
| Pexp_apply _ ->
(match self#simple_get_application x with
(* If it's the simple form of application. *)
| Some simpleGet -> Some simpleGet
| None -> None)
| Pexp_object cs -> Some (self#classStructure cs)
| Pexp_override l ->
(* FIXME *)
let string_x_expression (s, e) =
label ~space:true (atom (s.txt ^ ":")) (self#unparseExpr e)
in
Some
(makeList
~postSpace:true
~wrap:("{<", ">}")
~sep:(Sep ",")
(List.map ~f:string_x_expression l))
| Pexp_construct ({ txt = Lident "[]"; _ }, _)
when hasJsxAttribute ->
Some (atom "<> </>")
| Pexp_construct ({ txt = Lident "::"; _ }, Some _)
when hasJsxAttribute ->
(match self#formatJsxChildrenNonSpread x [] with
| None ->
(* Back out of the standard jsx child formatting *)
(* This is actually not a useful construct to have written:
* <> ... x </>
* Is the same as:
* x
* There is also a bug in the parser where a space is needed
* between <> and ..., but no one would write the ... form of
* <> anyways. *)
let withoutJsxAttributes =
{ x with pexp_attributes = stylisticAttrs @ arityAttrs }
in
self#simplest_expression withoutJsxAttributes
| Some chldn ->
Some
(makeList
~break:IfNeed
~inline:(false, false)
~postSpace:true
~wrap:("<>", "</>")
~pad:(true, true)
chldn))
| Pexp_construct _ when is_simple_construct (view_expr x) ->
Some
(match view_expr x with
| `nil -> atom "[]"
| `tuple -> atom "()"
| `btrue -> atom "true"
| `bfalse -> atom "false"
| `list xs ->
(* LIST EXPRESSION *)
self#unparseSequence ~construct:`List xs
| `cons xs -> self#unparseSequence ~construct:`ES6List xs
| `simple x -> self#longident x
| _ -> assert false)
| Pexp_ident li ->
(* Lone identifiers shouldn't break when to the right of a
label *)
Some (ensureSingleTokenSticksToLabel (self#longident_loc li))
| Pexp_constant c ->
(* Constants shouldn't break when to the right of a label *)
let raw_literal, _ =
Reason_attributes.extract_raw_literal x.pexp_attributes
in
Some
(ensureSingleTokenSticksToLabel
(self#constant ?raw_literal c))
| Pexp_pack me ->
Some
(makeList
~break:IfNeed
~postSpace:true
~wrap:("(", ")")
~inline:(true, true)
[ atom "module"; self#module_expr me ])
| Pexp_tuple l ->
(* TODO: These may be simple, non-simple, or type constrained
non-simple expressions *)
Some (self#unparseSequence ~construct:`Tuple l)
| Pexp_constraint (e, ct) ->
Some
(makeList
~break:IfNeed
~wrap:("(", ")")
[ formatTypeConstraint
(self#unparseExpr e)
(self#core_type ct)
])
| Pexp_coerce (e, cto1, ct) ->
let optFormattedType =
match cto1 with
| None -> None
| Some typ -> Some (self#core_type typ)
in
Some
(makeList
~break:IfNeed
~wrap:("(", ")")
[ formatCoerce
(self#unparseExpr e)
optFormattedType
(self#core_type ct)
])
| Pexp_variant (l, None) ->
Some
(ensureSingleTokenSticksToLabel
(atom ("`" ^ add_raw_identifier_prefix l)))
| Pexp_record (l, eo) -> Some (self#unparseRecord l eo)
| Pexp_array l -> Some (self#unparseSequence ~construct:`Array l)
| Pexp_let _ | Pexp_sequence _ | Pexp_letmodule _
| Pexp_letexception _ | Pexp_letop _ ->
Some (makeLetSequence (self#letList x))
| Pexp_extension e ->
(match expression_immediate_extension_sugar x with
| Some _, _ -> None
| None, _ ->
(match expression_extension_sugar x with
| None -> Some (self#extension e)
| Some (ext, x') ->
(match x'.pexp_desc with
| Pexp_let _ | Pexp_letop _ | Pexp_letmodule _ ->
Some (makeLetSequence (self#letList x))
| Pexp_constant (Pconst_string (i, _, Some delim)) ->
let { Reason_attributes.stylisticAttrs; _ } =
Reason_attributes.partitionAttributes
~allowUncurry:
(Reason_heuristics.melExprCanBeUncurried x')
x'.pexp_attributes
in
if
Reason_attributes.has_quoted_extension_attrs
stylisticAttrs
then Some (quoted_ext ext i delim)
else Some (self#extension e)
| _ -> Some (self#extension e))))
| Pexp_open (me, e) ->
if self#isSeriesOfOpensFollowedByNonSequencyExpression x
then
Some
(label
(label
(self#moduleExpressionToFormattedApplicationItems
me.popen_expr)
(atom "."))
(self#formatNonSequencyExpression ~parent:x e))
else Some (makeLetSequence (self#letList x))
| Pexp_send (e, s) ->
let needparens =
match e.pexp_desc with
| Pexp_apply (ee, _) ->
(match printedStringAndFixityExpr ee with
| UnaryPostfix "^" -> true
| _ -> false)
| _ -> false
in
let lhs = self#simple_enough_to_be_lhs_dot_send e in
let lhs =
if needparens then makeList ~wrap:("(", ")") [ lhs ] else lhs
in
Some (label (makeList [ lhs; atom "#" ]) (atom s.txt))
| Pexp_unreachable -> Some (atom ".")
| _ -> None
in
match item with
| None -> None
| Some i -> Some (source_map ~loc:x.pexp_loc i)
(* Renders jsx children. Returns None if it is not a valid JSX child *
structure and must be rendered as spread. You cannot render any list
of * JSX children in Reason unless it is nil-terminated. Otherwise
you must use * spread. *)
method formatJsxChildrenNonSpread expr processedRev =
let formatJsxChild x =
match x with
| { pexp_desc = Pexp_apply _; _ } as e ->
(* Pipe first behaves differently according to the expression on the
* right. In example (1) below, it's a `SpecificInfixPrecedence`; in
* (2), however, it's `Simple` and doesn't need to be wrapped in parens.
*
* (1). <div> {items->Belt.Array.map(ReasonReact.string)->ReasonReact.array} </div>;
* (2). <Foo> (title === "" ? [1, 2, 3] : blocks)->Foo.toString </Foo>; *)
if
Reason_heuristics.isPipeFirst e
&& not (Reason_heuristics.isPipeFirstWithNonSimpleJSXChild e)
then self#formatPipeFirst e
else
self#inline_braces#simplifyUnparseExpr
~inline:true
~wrap:("{", "}")
e
(* No braces - very simple *)
| { pexp_desc = Pexp_ident li; _ } -> self#longident_loc li
| { pexp_desc = Pexp_constant constant; _ } as x ->
let raw_literal, _ =
Reason_attributes.extract_raw_literal x.pexp_attributes
in
self#constant ?raw_literal constant
| _ ->
(* Currently spreading a list, or having a list as a child must be
* wrapped in { }. You can remove the entire even_wrap_simple arg
* when that is fixed (there is a conflict in grammar when allowing
* a [] without {[]} as child. *)
(* Simple child that has jsx: <hi> </hi> *)
(* Simple child that doesn't have jsx: "hello" *)
(* Simple child that doesn't have jsx but is a "::" and requires
braces: [a, b] *)
self#inline_braces#simplifyUnparseExpr
~inline:true
~wrap:("{", "}")
x
in
match expr with
| { pexp_desc = Pexp_construct ({ txt = Lident "[]"; _ }, None); _ }
->
(match processedRev with
| [] -> None
| _ :: _ -> Some (List.rev processedRev))
| { pexp_desc =
Pexp_construct
( { txt = Lident "::"; _ }
, Some { pexp_desc = Pexp_tuple [ hd; tl ]; _ } )
; _
} ->
self#formatJsxChildrenNonSpread
tl
(formatJsxChild hd :: processedRev)
| _ -> None
method direction_flag =
function Upto -> atom "to" | Downto -> atom "downto"
method payload ppxToken ppxId e =
let wrap = "[" ^ ppxToken ^ ppxId.txt, "]" in
let wrap_prefix str (x, y) = x ^ str, y in
let pad = true, false in
let postSpace = true in
match e with
| PStr [] -> atom ("[" ^ ppxToken ^ ppxId.txt ^ "]")
| PStr [ itm ] ->
makeList ~break:Layout.IfNeed ~wrap ~pad [ self#structure_item itm ]
| PStr (_ :: _ as items) ->
let rows = List.map ~f:self#structure_item items in
makeList
~wrap
~break:Layout.Always
~pad
~postSpace
~sep:(Layout.Sep ";")
rows
| PTyp x ->
let wrap = wrap_prefix ":" wrap in
makeList ~wrap ~break:Layout.IfNeed ~pad [ self#core_type x ]
(* Signatures in attributes were added recently *)
| PSig [] -> atom ("[" ^ ppxToken ^ ppxId.txt ^ ":]")
| PSig [ x ] ->
let wrap = wrap_prefix ":" wrap in
makeList ~break:Layout.IfNeed ~wrap ~pad [ self#signature_item x ]
| PSig items ->
let wrap = wrap_prefix ":" wrap in
let rows = List.map ~f:self#signature_item items in
makeList
~wrap
~break:Layout.IfNeed
~pad
~postSpace
~sep:(Layout.Sep ";")
rows
| PPat (x, None) ->
let wrap = wrap_prefix "?" wrap in
makeList
~wrap
~break:Layout.IfNeed
~pad
[ self#pattern_at_least_as_simple_as_alias_or_or x ]
| PPat (x, Some e) ->
let wrap = wrap_prefix "?" wrap in
makeList
~wrap
~break:Layout.IfNeed
~pad
~postSpace
[ self#pattern_at_least_as_simple_as_alias_or_or x
; label ~space:true (atom "when") (self#unparseExpr e)
]
(* [% ...] *)
method extension (s, p) =
match s.txt with
(* We special case "mel.obj" for now to allow for a nicer interop with
* Melange. We might be able to generalize to any kind of
* record looking thing with struct keys. *)
| "mel.obj" -> self#formatMelObjExtensionSugar p
| _ -> self#payload "%" s p
method item_extension (s, e) = self#payload "%%" s e
(* [@ ...] Simple attributes *)
method attribute =
function
| { attr_name = { Location.txt = "ocaml.doc" | "ocaml.text"; _ }
; attr_payload =
PStr
[ { pstr_desc =
Pstr_eval
( { pexp_desc =
Pexp_constant (Pconst_string (text, _, None))
; _
}
, _ )
; pstr_loc
}
]
; _
} ->
let break = if text = "" then Layout.IfNeed else Always_rec in
let text = if text = "" then "/**/" else "/**" ^ text ^ "*/" in
makeList
~inline:(true, true)
~postSpace:true
~preSpace:true
~indent:0
~break
[ atom ~loc:pstr_loc text ]
| { attr_name; attr_payload; _ } ->
self#payload "@" attr_name attr_payload
(* [@@ ... ] Attributes that occur after a major item in a
structure/class *)
method item_attribute = self#attribute
(* [@@ ...] Attributes that occur not *after* an item in some
structure/class/sig, but rather as their own standalone item. Note
that syntactic distinction between item_attribute and
floating_attribute is no longer necessary with Reason. Thank you
semicolons. *)
method floating_attribute = self#item_attribute
method attributes l = List.map ~f:self#attribute l
method attach_std_attrs l toThis =
let l = Reason_attributes.extractStdAttrs l in
match l with
| [] -> toThis
| _ :: _ ->
makeList
~postSpace:true
(List.concat [ self#attributes l; [ toThis ] ])
method attach_std_item_attrs ?(allowUncurry = true) ?extension l toThis
=
let attrs = Reason_attributes.partitionAttributes ~allowUncurry l in
match extension, attrs.stdAttrs with
| None, [] -> toThis
| Some id, _ ->
makeList
~wrap:("[%" ^ id.txt, "]")
~indent:1
~pad:(true, false)
~break:Layout.IfNeed
(List.map ~f:self#item_attribute l @ [ toThis ])
| None, _ ->
makeList
~postSpace:true
~indent:0
~break:Always
~inline:(true, true)
(List.map ~f:self#item_attribute l @ [ toThis ])
method exception_declaration ed =
let pcd_name = ed.pext_name in
let pcd_loc = ed.pext_loc in
let pcd_attributes = [] in
let exn_arg =
match ed.pext_kind with
| Pext_decl (vars, args, type_opt) ->
let pcd_args, pcd_res = args, type_opt in
[ self#type_variant_leaf_nobar
{ pcd_name
; pcd_args
; pcd_res
; pcd_loc
; pcd_attributes
; pcd_vars = vars
}
]
| Pext_rebind id ->
[ atom pcd_name.txt; atom "="; self#longident_loc id ]
in
let { Reason_attributes.stdAttrs; docAttrs; _ } =
Reason_attributes.partitionAttributes
~partDoc:true
ed.pext_attributes
in
let layout =
self#attach_std_item_attrs
stdAttrs
(label
~space:true
(atom "exception")
(makeList ~postSpace:true ~inline:(true, true) exn_arg))
in
self#attachDocAttrsToLayout
~stdAttrs
~docAttrs
~loc:ed.pext_loc
~layout
()
(* Note: that override doesn't appear in class_sig_field, but does occur
in class/object expressions. TODO: TODOATTRIBUTES *)
method method_sig_flags_for s =
function
| Virtual -> [ atom "virtual"; atom s ]
| Concrete -> [ atom s ]
method value_type_flags_for s =
function
| Virtual, Mutable -> [ atom "virtual"; atom "mutable"; atom s ]
| Virtual, Immutable -> [ atom "virtual"; atom s ]
| Concrete, Mutable -> [ atom "mutable"; atom s ]
| Concrete, Immutable -> [ atom s ]
method class_sig_field x =
match x.pctf_desc with
| Pctf_inherit ct ->
label ~space:true (atom "inherit") (self#class_constructor_type ct)
| Pctf_val (s, mf, vf, ct) ->
let valueFlags = self#value_type_flags_for (s.txt ^ ":") (vf, mf) in
label
~space:true
(label
~space:true
(atom "val")
(makeList
~postSpace:true
~inline:(false, true)
~break:IfNeed
valueFlags))
(self#core_type ct)
| Pctf_method (s, pf, vf, ct) ->
let methodFlags = self#method_sig_flags_for (s.txt ^ ":") vf in
let pubOrPrivate =
match pf with Private -> "pri" | Public -> "pub"
in
let m =
label
~space:true
(label
~space:true
(atom pubOrPrivate)
(makeList
~postSpace:true
~inline:(false, true)
~break:IfNeed
methodFlags))
(self#core_type ct)
in
self#attach_std_item_attrs x.pctf_attributes m
| Pctf_constraint (ct1, ct2) ->
label
~space:true
(atom "constraint")
(label
~space:true
(makeList ~postSpace:true [ self#core_type ct1; atom "=" ])
(self#core_type ct2))
| Pctf_attribute a -> self#floating_attribute a
| Pctf_extension e -> self#item_extension e
(* * /** doc comment */ (* formattedDocs *) * [@bs.val] [@bs.module
"react-dom"] (* formattedAttrs *) * external render : reactElement =>
element => unit = (* frstHalf *) * "render"; (* sndHalf *)
* To improve the formatting with breaking & indentation: * * consider
the part before the '=' as a label * * combine that label with '=' in
a list * * consider the part after the '=' as a list * * combine both
parts as a label * * format the doc comment with a ~postSpace:true
(inline, not inline) list * * format the attributes with a
~postSpace:true (inline, inline) list * * format everything together
in a ~postSpace:true (inline, inline) list * for nicer breaking *)
method primitive_declaration ?extension vd =
let external_label = add_extension_sugar "external" extension in
let lblBefore =
label
~space:true
(makeList
[ makeList
~postSpace:true
[ atom external_label; protectIdentifier vd.pval_name.txt ]
; atom ":"
])
(self#core_type vd.pval_type)
in
let primDecl =
match vd.pval_prim with
| [ "" ] -> lblBefore
| _ ->
let frstHalf = makeList ~postSpace:true [ lblBefore; atom "=" ] in
let sndHalf =
makeSpacedBreakableInlineList
(List.map ~f:self#constant_string_for_primitive vd.pval_prim)
in
label ~space:true frstHalf sndHalf
in
match vd.pval_attributes with
| [] -> primDecl
| attrs ->
let { Reason_attributes.stdAttrs; docAttrs; _ } =
Reason_attributes.partitionAttributes ~partDoc:true attrs
in
let docs = List.map ~f:self#item_attribute docAttrs in
let formattedDocs = makeList ~postSpace:true docs in
let attrs = List.map ~f:self#item_attribute stdAttrs in
let formattedAttrs = makeSpacedBreakableInlineList attrs in
let layouts =
match docAttrs, stdAttrs with
| [], _ -> [ formattedAttrs; primDecl ]
| _, [] -> [ formattedDocs; primDecl ]
| _ -> [ formattedDocs; formattedAttrs; primDecl ]
in
makeSpacedBreakableInlineList layouts
method classTypeSigsAndRest x =
match x.pcty_desc with
| Pcty_signature cs ->
let { pcsig_self = ct; pcsig_fields = l } = cs in
let instTypeFields = List.map ~f:self#class_sig_field l in
let allItems =
match ct.ptyp_desc with
| Ptyp_any -> instTypeFields
| _ ->
label ~space:true (atom "as") (self#core_type ct)
:: instTypeFields
in
allItems
| _ -> [ self#class_instance_type x ]
method class_instance_type x =
match x.pcty_desc with
| Pcty_signature _ | Pcty_open _ ->
let opens, rest = self#classTypeOpens x in
let cs = self#classTypeSigsAndRest rest in
self#attach_std_item_attrs
~allowUncurry:false
x.pcty_attributes
(makeList
~wrap:("{", "}")
~postSpace:true
~break:Layout.Always_rec
(List.map ~f:semiTerminated (List.concat [ opens; cs ])))
| Pcty_constr (li, l) ->
self#attach_std_attrs
x.pcty_attributes
(match l with
| [] -> self#longident_loc li
| _ :: _ ->
label
(self#longident_loc li)
(makeList
~wrap:("(", ")")
~sep:commaTrail
(List.map ~f:self#core_type l)))
| Pcty_extension e ->
self#attach_std_item_attrs x.pcty_attributes (self#extension e)
| Pcty_arrow _ ->
failwith "class_instance_type should not be printed with Pcty_arrow"
method classTypeOpens x =
let rec gatherOpens acc opn =
match opn.pcty_desc with
| Pcty_open (md, ct) ->
let li = md.popen_expr in
gatherOpens
(source_map
~loc:li.loc
(label
~space:true
(atom ("open" ^ override md.popen_override))
(self#longident_loc li))
:: acc)
ct
| _ -> List.rev acc, opn
in
gatherOpens [] x
method class_declaration_list l =
let class_declaration
?(class_keyword = false)
({ pci_params = ls
; pci_name = { txt; _ }
; pci_virt
; pci_loc
; _
} as x)
=
let firstToken, pattern, patternAux =
self#class_opening class_keyword txt pci_virt ls
in
let classBinding =
self#wrappedClassBinding firstToken pattern patternAux x.pci_expr
in
source_map
~loc:pci_loc
(self#attach_std_item_attrs x.pci_attributes classBinding)
in
match l with
| [] ->
raise (NotPossible "Class definitions will have at least one item.")
| x :: rest ->
makeNonIndentedBreakingList
(class_declaration ~class_keyword:true x
:: List.map ~f:class_declaration rest)
(* For use with [class type a = class_instance_type]. Class type
declarations/definitions declare the types of instances generated by
class constructors. We have to call self#class_instance_type because
self#class_constructor_type would add a "new" before the type. TODO:
TODOATTRIBUTES: *)
method class_type_declaration_list l =
let class_type_declaration
kwd
({ pci_params = ls; pci_name; pci_attributes; _ } as x)
=
let opener =
match x.pci_virt with
| Virtual -> kwd ^ " " ^ "virtual"
| Concrete -> kwd
in
let upToName =
let name = add_raw_identifier_prefix pci_name.txt in
if ls == []
then label ~space:true (atom opener) (atom name)
else
label
~space:true
(label ~space:true (atom opener) (atom name))
(self#class_params_def ls)
in
let includingEqual =
makeList ~postSpace:true [ upToName; atom "=" ]
in
let { Reason_attributes.stdAttrs; docAttrs; _ } =
Reason_attributes.partitionAttributes ~partDoc:true pci_attributes
in
let layout =
self#attach_std_item_attrs stdAttrs
@@ label
~space:true
includingEqual
(self#class_instance_type x.pci_expr)
in
self#attachDocAttrsToLayout
~stdAttrs
~docAttrs
~loc:pci_name.loc
~layout
()
in
match l with
| [] ->
failwith "Should not call class_type_declaration with no classes"
| [ x ] -> class_type_declaration "class type" x
| x :: xs ->
makeList
~break:Always_rec
~indent:0
~inline:(true, true)
(class_type_declaration "class type" x
:: List.map ~f:(class_type_declaration "and") xs)
(* Formerly the [class_type] Notice how class_constructor_type doesn't
have any type attributes - class_instance_type does. TODO: Divide
into class_constructor_types that allow arrows and ones that
don't. *)
method class_constructor_type x =
match x.pcty_desc with
| Pcty_arrow _ ->
let rec allArrowSegments acc = function
| { pcty_desc = Pcty_arrow (l, ct1, ct2); _ } ->
allArrowSegments
(self#type_with_label (l, ct1, false) :: acc)
ct2
(* This "new" is unfortunate. See reason_parser.mly for
details. *)
| xx -> List.rev acc, self#class_constructor_type xx
in
let params, return = allArrowSegments [] x in
let normalized =
makeList
~break:IfNeed
~sep:(Sep "=>")
~preSpace:true
~postSpace:true
~inline:(true, true)
[ makeCommaBreakableListSurround "(" ")" params; return ]
in
source_map ~loc:x.pcty_loc normalized
| _ ->
(* Unfortunately, we have to have final components of a
class_constructor_type be prefixed with the `new` keyword.
Hopefully this is temporary. *)
self#class_instance_type x
method non_arrowed_class_constructor_type x =
match x.pcty_desc with
| Pcty_arrow _ ->
source_map
~loc:x.pcty_loc
(formatPrecedence (self#class_constructor_type x))
| _ -> self#class_instance_type x
method class_field x =
let itm =
match x.pcf_desc with
| Pcf_inherit (ovf, ce, so) ->
let inheritText = "inherit" ^ override ovf in
let inheritExp = self#class_expr ce in
label
~space:true
(atom inheritText)
(match so with
| None -> inheritExp
| Some s -> label ~space:true inheritExp (atom ("as " ^ s.txt)))
| Pcf_val (s, mf, Cfk_concrete (ovf, e)) ->
let opening =
match mf with
| Mutable ->
let mutableName = [ atom "mutable"; atom s.txt ] in
label
~space:true
(atom ("val" ^ override ovf))
(makeList
~postSpace:true
~inline:(false, true)
~break:IfNeed
mutableName)
| Immutable ->
label ~space:true (atom ("val" ^ override ovf)) (atom s.txt)
in
let valExprAndConstraint =
match e.pexp_desc with
| Pexp_constraint (ex, ct) ->
let openingWithTypeConstraint =
formatTypeConstraint opening (self#core_type ct)
in
label
~space:true
(makeList
~postSpace:true
[ openingWithTypeConstraint; atom "=" ])
(self#unparseExpr ex)
| _ ->
label
~space:true
(makeList ~postSpace:true [ opening; atom "=" ])
(self#unparseExpr e)
in
valExprAndConstraint
| Pcf_val (s, mf, Cfk_virtual ct) ->
let opening =
match mf with
| Mutable ->
let mutableVirtualName =
[ atom "mutable"; atom "virtual"; atom s.txt ]
in
let openingTokens =
makeList
~postSpace:true
~inline:(false, true)
~break:IfNeed
mutableVirtualName
in
label ~space:true (atom "val") openingTokens
| Immutable ->
let virtualName = [ atom "virtual"; atom s.txt ] in
let openingTokens =
makeList
~postSpace:true
~inline:(false, true)
~break:IfNeed
virtualName
in
label ~space:true (atom "val") openingTokens
in
formatTypeConstraint opening (self#core_type ct)
| Pcf_method (s, pf, Cfk_virtual ct) ->
let opening =
match pf with
| Private ->
let privateVirtualName = [ atom "virtual"; atom s.txt ] in
let openingTokens =
makeList
~postSpace:true
~inline:(false, true)
~break:IfNeed
privateVirtualName
in
label ~space:true (atom "pri") openingTokens
| Public ->
let virtualName = [ atom "virtual"; atom s.txt ] in
let openingTokens =
makeList
~postSpace:true
~inline:(false, true)
~break:IfNeed
virtualName
in
label ~space:true (atom "pub") openingTokens
in
formatTypeConstraint opening (self#core_type ct)
| Pcf_method (s, pf, Cfk_concrete (ovf, e)) ->
let methodText =
let postFix = if ovf == Override then "!" else "" in
match pf with
| Private -> "pri" ^ postFix
| Public -> "pub" ^ postFix
in
(* Should refactor the binding logic so faking out the AST isn't
needed, currently, it includes a ton of nuanced logic around
recovering explicitly polymorphic type definitions, and that
furthermore, that representation... Actually, let's do it.
For some reason, concrete methods are only ever parsed as
Pexp_poly. If there *is* no polymorphic function for the
method, then the return value of the function is wrapped in a
ghost Pexp_poly with [None] for the type vars.*)
(match e.pexp_desc with
| Pexp_poly
( { pexp_desc =
Pexp_constraint
(methodFunWithNewtypes, nonVarifiedExprType)
; _
}
, Some
{ ptyp_desc = Ptyp_poly (typeVars, varifiedPolyType); _ }
)
when let leadingAbstractVars, _ =
self#leadingCurriedAbstractTypes methodFunWithNewtypes
in
self#isRenderableAsPolymorphicAbstractTypes
typeVars
(* If even artificially varified. Don't know until this
returns*)
varifiedPolyType
leadingAbstractVars
nonVarifiedExprType ->
let leadingAbstractVars, _ =
self#leadingCurriedAbstractTypes methodFunWithNewtypes
in
self#locallyAbstractPolymorphicFunctionBinding
methodText
(atom s.txt)
methodFunWithNewtypes
leadingAbstractVars
nonVarifiedExprType
| Pexp_poly (e, Some ct) ->
self#formatSimplePatternBinding
methodText
(atom s.txt)
(Some
( source_map ~loc:ct.ptyp_loc (self#core_type ct)
, `Constraint ))
(self#unparseExprApplicationItems e)
(* This form means that there is no type constraint - it's a
strange node name.*)
| Pexp_poly (e, None) ->
self#wrappedBinding methodText ~arrow:"=>" (atom s.txt) [] e
| _ ->
failwith "Concrete methods should only ever have Pexp_poly.")
| Pcf_constraint (ct1, ct2) ->
label
~space:true
(atom "constraint")
(makeList
~postSpace:true
~inline:(true, false)
[ makeList ~postSpace:true [ self#core_type ct1; atom "=" ]
; self#core_type ct2
])
| Pcf_initializer e ->
label
~space:true
(atom "initializer")
(self#simplifyUnparseExpr e)
| Pcf_attribute a -> self#floating_attribute a
| Pcf_extension e ->
(* And don't forget, we still need to print post_item_attributes
even for this case *)
self#item_extension e
in
let layout = self#attach_std_attrs x.pcf_attributes itm in
source_map ~loc:x.pcf_loc layout
method class_self_pattern_and_structure
{ pcstr_self = p; pcstr_fields = l } =
let fields = List.map ~f:self#class_field l in
(* Recall that by default self is bound to "this" at parse time. You'd
have to go out of your way to bind it to "_". *)
match p.ppat_attributes, p.ppat_desc with
| [], Ppat_var { txt = "this"; _ } -> fields
| _ ->
let field = label ~space:true (atom "as") (self#pattern p) in
source_map ~loc:p.ppat_loc field :: fields
method simple_class_expr x =
let { Reason_attributes.stdAttrs; _ } =
Reason_attributes.partitionAttributes x.pcl_attributes
in
if stdAttrs != []
then
formatSimpleAttributed
(self#simple_class_expr { x with pcl_attributes = [] })
(self#attributes stdAttrs)
else
let itm =
match x.pcl_desc with
| Pcl_constraint (ce, ct) ->
formatTypeConstraint
(self#class_expr ce)
(self#class_constructor_type ct)
(* In OCaml, * - In the most recent version of OCaml, when in the
top level of a * module, let _ = ... is a PStr_eval. * - When
in a function, it is a Pexp_let PPat_any * - When in class
pre-member let bindings it is a Pcl_let PPat_any * * Reason
normalizes all of these to be simple imperative expressions *
with trailing semicolons, *except* in the case of classes
because it * will likely introduce a conflict with some
proposed syntaxes for * objects. *)
| Pcl_let _ | Pcl_structure _ | Pcl_open _ ->
let opens, rest = self#classExprOpens x in
let rows = self#classExprLetsAndRest rest in
makeList
~wrap:("{", "}")
~inline:(true, false)
~postSpace:true
~break:Always_rec
(List.map ~f:semiTerminated (List.concat [ opens; rows ]))
| Pcl_extension e -> self#extension e
| _ -> formatPrecedence (self#class_expr x)
in
source_map ~loc:x.pcl_loc itm
method classExprLetsAndRest x =
match x.pcl_desc with
| Pcl_structure cs -> self#class_self_pattern_and_structure cs
| Pcl_let (rf, l, ce) ->
(* For "letList" bindings, the start/end isn't as simple as with
* module value bindings. For "let lists", the sequences were formed
* within braces {}. The parser relocates the first let binding to the
* first brace. *)
let binding =
source_map
~loc:(self#bindingsLocationRange l)
(self#bindings (rf, l))
in
binding :: self#classExprLetsAndRest ce
| Pcl_open (_, ce) -> self#classExprLetsAndRest ce
| _ -> [ self#class_expr x ]
method classExprOpens x =
let rec gatherOpens acc opn =
match opn.pcl_desc with
| Pcl_open (md, ce) ->
let li = md.popen_expr in
gatherOpens
(source_map
~loc:li.loc
(label
~space:true
(atom ("open" ^ override md.popen_override))
(self#longident_loc li))
:: acc)
ce
| _ -> List.rev acc, opn
in
gatherOpens [] x
method class_expr x =
let { Reason_attributes.stdAttrs; _ } =
Reason_attributes.partitionAttributes x.pcl_attributes
in
(* We cannot handle the attributes here. Must handle them in each
item *)
if stdAttrs != []
then
(* Do not need a "simple" attributes precedence wrapper. *)
formatAttributed
(self#simple_class_expr { x with pcl_attributes = [] })
(self#attributes stdAttrs)
else
match x.pcl_desc with
| Pcl_fun _ ->
(match self#curriedConstructorPatternsAndReturnVal x with
| None, _ ->
(* x just matched Pcl_fun, there is at least one parameter *)
assert false
| Some args, e ->
label
~space:true
(makeList
~postSpace:true
[ label ~space:true (atom funToken) args; atom "=>" ])
(self#class_expr e))
| Pcl_apply _ ->
formatAttachmentApplication
applicationFinalWrapping
None
(self#classExpressionToFormattedApplicationItems x, None)
| Pcl_constr (li, []) ->
label ~space:true (atom "class") (self#longident_loc li)
| Pcl_constr (li, l) ->
label
(makeList
~postSpace:true
[ atom "class"; self#longident_loc li ])
(makeTup (List.map ~f:self#non_arrowed_non_simple_core_type l))
| Pcl_open _ | Pcl_constraint _ | Pcl_extension _ | Pcl_let _
| Pcl_structure _ ->
self#simple_class_expr x
method classStructure ?(forceBreak = false) ?(wrap = "", "") cs =
let left, right = wrap in
let fields_layout = self#class_self_pattern_and_structure cs in
let pad = match fields_layout with [] -> false | _ :: _ -> true in
makeList
~sep:(Layout.Sep ";")
~wrap:(left ^ "{", "}" ^ right)
~break:(if forceBreak then Layout.Always else Layout.IfNeed)
~postSpace:true
~pad:(pad, pad)
~inline:(true, false)
fields_layout
method signature signatureItems =
match signatureItems with
| [] -> atom ""
| first :: _ as signatureItems ->
let last =
match List.rev signatureItems with
| last :: _ -> last
| [] -> assert false
in
let loc_start = first.psig_loc.loc_start in
let loc_end = last.psig_loc.loc_end in
let items =
groupAndPrint
~xf:self#signature_item
~getLoc:(fun x -> x.psig_loc)
~comments:self#comments
signatureItems
in
source_map
~loc:{ loc_start; loc_end; loc_ghost = false }
(makeList
~postSpace:true
~break:Layout.Always_rec
~indent:0
~inline:(true, false)
~sep:(SepFinal (";", ";"))
items)
method signature_item item : Layout.t =
match item.psig_desc with
| Psig_extension ((extension, PSig [ item ]), _attrs) ->
(match item.psig_desc with
(* In case of a value or `external`, the extension gets inlined
`let%private a = 1` *)
| Psig_value ({ pval_prim = [ _ ]; _ } as vd) ->
self#primitive_declaration ~extension vd
| Psig_value vd -> self#val_binding ~extension vd
| Psig_module pmd -> self#psig_module ~extension pmd
| Psig_recmodule pmd -> self#psig_recmodule ~extension pmd
| Psig_open od -> self#psig_open ~extension od
| Psig_type (rf, l) -> self#type_def_list ~extension rf l
| Psig_typext te -> self#type_extension ~extension te
| _ -> self#payload "%%" extension (PSig [ item ]))
| _ -> self#signature_item' item
method val_binding ?extension vd =
let intro = add_extension_sugar "let" extension in
let { Reason_attributes.stdAttrs; docAttrs; _ } =
Reason_attributes.partitionAttributes
~partDoc:true
vd.pval_attributes
in
let layout =
self#attach_std_item_attrs
stdAttrs
(formatTypeConstraint
(label
~space:true
(atom intro)
(source_map
~loc:vd.pval_name.loc
(protectIdentifier vd.pval_name.txt)))
(self#core_type vd.pval_type))
in
self#attachDocAttrsToLayout
~stdAttrs
~docAttrs
~loc:vd.pval_loc
~layout
()
method psig_module ?extension pmd =
let layout =
let prefix = add_extension_sugar "module" extension in
match pmd.pmd_type.pmty_desc with
| Pmty_alias alias ->
label
~space:true
(makeList
~postSpace:true
[ atom prefix; atom (moduleIdent pmd.pmd_name); atom "=" ])
(self#longident_loc alias)
| _ ->
let letPattern =
makeList
[ makeList
~postSpace:true
[ atom prefix; atom (moduleIdent pmd.pmd_name) ]
; atom ":"
]
in
self#module_type letPattern pmd.pmd_type
in
let { Reason_attributes.stdAttrs; docAttrs; _ } =
Reason_attributes.partitionAttributes
~partDoc:true
pmd.pmd_attributes
in
self#attachDocAttrsToLayout
~stdAttrs
~docAttrs
~loc:pmd.pmd_name.loc
~layout:(self#attach_std_item_attrs stdAttrs @@ layout)
()
method psig_recmodule ?extension decls =
let items =
List.mapi
~f:(fun i xx ->
let { Reason_attributes.stdAttrs; docAttrs; _ } =
Reason_attributes.partitionAttributes
~partDoc:true
xx.pmd_attributes
in
let letPattern =
makeList
[ makeList
~postSpace:true
[ atom
(if i == 0
then
add_extension_sugar "module" extension ^ " rec"
else "and")
; atom (moduleIdent xx.pmd_name)
]
; atom ":"
]
in
let layout =
self#attach_std_item_attrs
stdAttrs
(self#module_type ~space:true letPattern xx.pmd_type)
in
let layoutWithDocAttrs =
self#attachDocAttrsToLayout
~stdAttrs
~docAttrs
~loc:xx.pmd_name.loc
~layout
()
in
extractLocModDecl xx, layoutWithDocAttrs)
decls
in
makeNonIndentedBreakingList
(groupAndPrint
~xf:(fun (_, layout) -> layout)
~getLoc:(fun (loc, _) -> loc)
~comments:self#comments
items)
method psig_open ?extension od =
let { Reason_attributes.stdAttrs; docAttrs; _ } =
Reason_attributes.partitionAttributes
~partDoc:true
od.popen_attributes
in
let layout =
let open_prefix =
add_open_extension_sugar ~override:od.popen_override extension
in
self#attach_std_item_attrs stdAttrs
@@ label
~space:true
(atom open_prefix)
(self#longident_loc od.popen_expr)
in
self#attachDocAttrsToLayout
~stdAttrs
~docAttrs
~loc:od.popen_expr.loc
~layout
()
method modtype x ~delim =
let name = atom (add_raw_identifier_prefix x.pmtd_name.txt) in
let main =
match x.pmtd_type with
| None -> makeList ~postSpace:true [ atom "module type"; name ]
| Some mt ->
let letPattern =
makeList
~postSpace:true
[ atom "module type"; name; atom delim ]
in
self#module_type letPattern mt
in
let { Reason_attributes.stdAttrs; docAttrs; _ } =
Reason_attributes.partitionAttributes
~partDoc:true
x.pmtd_attributes
in
let layout = self#attach_std_item_attrs stdAttrs main in
self#attachDocAttrsToLayout
~stdAttrs
~docAttrs
~loc:x.pmtd_name.loc
~layout
()
method signature_item' x : Layout.t =
let item : Layout.t =
match x.psig_desc with
| Psig_type (rf, l) -> self#type_def_list rf l
| Psig_value vd ->
if vd.pval_prim != []
then self#primitive_declaration vd
else self#val_binding vd
| Psig_typext te -> self#type_extension te
| Psig_exception ed ->
self#exception_declaration
{ ed.ptyexn_constructor with
pext_attributes =
ed.ptyexn_attributes @ ed.ptyexn_constructor.pext_attributes
}
| Psig_class l ->
let class_description
?(class_keyword = false)
({ pci_params = ls; pci_name = { txt; _ }; pci_loc; _ } as x)
=
let firstToken, pattern, patternAux =
self#class_opening class_keyword txt x.pci_virt ls
in
let withColon =
self#wrapCurriedFunctionBinding
~arrow:":"
~spaceBeforeArrow:false
firstToken
pattern
patternAux
([ self#class_constructor_type x.pci_expr ], None)
in
let { Reason_attributes.stdAttrs; docAttrs; _ } =
Reason_attributes.partitionAttributes
~partDoc:true
x.pci_attributes
in
let layout = self#attach_std_item_attrs stdAttrs withColon in
source_map
~loc:pci_loc
(self#attachDocAttrsToLayout
~stdAttrs
~docAttrs
~loc:x.pci_name.loc
~layout
())
in
makeNonIndentedBreakingList
(match l with
| [] -> raise (NotPossible "No recursive class bindings")
| [ x ] -> [ class_description ~class_keyword:true x ]
| x :: xs ->
class_description ~class_keyword:true x
:: List.map ~f:class_description xs)
| Psig_module pmd -> self#psig_module pmd
| Psig_open od -> self#psig_open od
| Psig_include incl ->
let { Reason_attributes.stdAttrs; docAttrs; _ } =
Reason_attributes.partitionAttributes
~partDoc:true
incl.pincl_attributes
in
let layout =
self#attach_std_item_attrs stdAttrs
@@ self#module_type (atom "include") incl.pincl_mod
in
self#attachDocAttrsToLayout
~stdAttrs
~docAttrs
~loc:incl.pincl_mod.pmty_loc
~layout
()
| Psig_modtype x -> self#modtype x ~delim:"="
| Psig_class_type l -> self#class_type_declaration_list l
| Psig_recmodule decls -> self#psig_recmodule decls
| Psig_attribute a -> self#floating_attribute a
| Psig_extension ((({ loc; _ }, _) as ext), attrs) ->
let { Reason_attributes.stdAttrs; docAttrs; _ } =
Reason_attributes.partitionAttributes ~partDoc:true attrs
in
let layout =
self#attach_std_item_attrs stdAttrs (self#item_extension ext)
in
self#attachDocAttrsToLayout ~stdAttrs ~docAttrs ~loc ~layout ()
| Psig_modsubst { pms_name; pms_manifest; pms_attributes; pms_loc }
->
let name = atom pms_name.txt in
let main =
makeList
~postSpace:true
[ atom "module"
; name
; atom ":="
; self#longident_loc pms_manifest
]
in
let { Reason_attributes.stdAttrs; docAttrs; _ } =
Reason_attributes.partitionAttributes
~partDoc:true
pms_attributes
in
let layout = self#attach_std_item_attrs stdAttrs main in
self#attachDocAttrsToLayout
~stdAttrs
~docAttrs
~loc:pms_loc
~layout
()
| Psig_typesubst l -> self#type_def_list ~eq_symbol:":=" Recursive l
| Psig_modtypesubst x -> self#modtype x ~delim:":="
in
source_map ~loc:x.psig_loc item
method non_arrowed_module_type ?(space = true) letPattern x =
match x.pmty_desc with
| Pmty_alias li ->
label
~space
letPattern
(formatPrecedence
(label ~space:true (atom "module") (self#longident_loc li)))
| Pmty_typeof me ->
let labelWithoutFinalWrap =
label
~space:true
(label
~space:true
letPattern
(makeList
~inline:(false, false)
~wrap:("(", "")
~postSpace:true
[ atom "module type of" ]))
(self#module_expr me)
in
makeList ~wrap:("", ")") [ labelWithoutFinalWrap ]
| _ -> self#simple_module_type ~space letPattern x
method simple_module_type ?(space = true) letPattern x =
match x.pmty_desc with
| Pmty_ident li -> label ~space letPattern (self#longident_loc li)
| Pmty_signature s ->
let items =
groupAndPrint
~xf:self#signature_item
~getLoc:(fun x -> x.psig_loc)
~comments:self#comments
s
in
let shouldBreakLabel = match s with [] -> `Auto | _ -> `Always in
label
~indent:0
~break:shouldBreakLabel
(makeList
[ label
~break:shouldBreakLabel
(makeList ~postSpace:true [ letPattern; atom "{" ])
(source_map
~loc:x.pmty_loc
(makeList
~break:(match s with [] -> IfNeed | _ -> Always)
~inline:(true, true)
~postSpace:true
~sep:(SepFinal (";", ";"))
items))
])
(atom "}")
| Pmty_extension (s, e) ->
label ~space letPattern (self#payload "%" s e)
| _ ->
makeList
~break:IfNeed
~wrap:("", ")")
[ self#module_type
~space:false
(makeList ~pad:(false, true) ~wrap:("", "(") [ letPattern ])
x
]
method module_type ?(space = true) letPattern x =
let pmty =
match x.pmty_desc with
| Pmty_functor _ ->
(* The segments that should be separated by arrows. *)
let rec extract_args args xx =
match xx.pmty_desc with
| Pmty_functor (Unit, mt2) -> extract_args (`Unit :: args) mt2
| Pmty_functor (Named ({ txt = s; _ }, mt1), mt2) ->
let arg =
match s with
| None -> self#module_type ~space:false (atom "") mt1
| Some s ->
self#module_type
~space
(makeList [ atom s; atom ":" ])
mt1
in
extract_args (`Arg arg :: args) mt2
| _ ->
let prepare_arg = function
| `Unit -> atom "()"
| `Arg x -> x
in
let args =
match args with
| [ `Unit ] -> []
| _ -> List.rev_map ~f:prepare_arg args
in
args, self#module_type (atom "") xx
in
let args, ret = extract_args [] x in
label
~space
letPattern
(makeList
~break:IfNeed
~sep:(Sep "=>")
~preSpace:true
~inline:(true, true)
[ makeTup args; ret ])
(* See comments in sugar_parser.mly about why WITH constraints
aren't "non * arrowed" *)
| Pmty_with (mt, l) ->
let modSub atm li2 token =
makeList
~postSpace:true
[ atom "module"; atm; atom token; self#longident_loc li2 ]
in
let modtypeSub atm li modtype =
label
(makeList
~break:IfNeed
~sep:(Sep " ")
[ atom "module type"; self#longident li; atm ])
(self#module_type (atom "") modtype)
in
let typeAtom = atom "type" in
let eqAtom = atom "=" in
let destrAtom = atom ":=" in
let with_constraint = function
| Pwith_type (li, td) ->
self#formatOneTypeDef
typeAtom
(makeList ~preSpace:true [ self#longident_loc li ])
eqAtom
td
| Pwith_module (li, li2) ->
modSub (self#longident_loc li) li2 "="
| Pwith_typesubst (_, td) ->
self#formatOneTypeDef
typeAtom
(atom ~loc:td.ptype_name.loc td.ptype_name.txt)
destrAtom
td
| Pwith_modsubst (s, li2) ->
modSub (self#longident s.txt) li2 ":="
| Pwith_modtype (s, modtype) -> modtypeSub eqAtom s.txt modtype
| Pwith_modtypesubst (s, modtype) ->
modtypeSub destrAtom s.txt modtype
in
(match l with
| [] -> self#module_type ~space letPattern mt
| _ ->
label
~space
letPattern
(label
~space:true
(makeList
~preSpace:true
[ self#module_type ~space:false (atom "") mt
; atom "with"
])
(makeList
~break:IfNeed
~inline:(true, true)
~sep:(Sep "and")
~postSpace:true
~preSpace:true
(List.map ~f:with_constraint l))))
(* Seems like an infinite loop just waiting to happen. *)
| _ -> self#non_arrowed_module_type ~space letPattern x
in
source_map ~loc:x.pmty_loc pmty
method simple_module_expr ?(hug = false) x =
match x.pmod_desc with
| Pmod_unpack e ->
let exprLayout =
match e.pexp_desc with
| Pexp_constraint (e, { ptyp_desc = Ptyp_package (lid, cstrs); _ })
->
formatTypeConstraint
(makeList ~postSpace:true [ atom "val"; self#unparseExpr e ])
(self#typ_package ~mod_prefix:false lid cstrs)
| _ -> makeList ~postSpace:true [ atom "val"; self#unparseExpr e ]
in
formatPrecedence exprLayout
| Pmod_ident li ->
ensureSingleTokenSticksToLabel (self#longident_loc li)
| Pmod_constraint (unconstrainedRet, mt) ->
let letPattern =
makeList [ self#module_expr unconstrainedRet; atom ":" ]
in
formatPrecedence (self#module_type letPattern mt)
| Pmod_structure s ->
let wrap =
if hug then if s = [] then "(", ")" else "({", "})" else "{", "}"
in
self#structure ~indent:None ~wrap s
| _ ->
(* For example, functor application will be wrapped. *)
formatPrecedence ~wrap:("", "") (self#module_expr x)
method module_expr x =
match x.pmod_desc with
| Pmod_functor _ ->
let argsList, return =
self#curriedFunctorPatternsAndReturnStruct x
in
(* See #19/20 in syntax.mls - cannot annotate return type at the
moment. *)
self#wrapCurriedFunctionBinding
funToken
~sweet:true
~arrow:"=>"
(makeTup argsList)
[]
([ self#moduleExpressionToFormattedApplicationItems return ], None)
| Pmod_apply _ | Pmod_apply_unit _ ->
self#moduleExpressionToFormattedApplicationItems x
| Pmod_extension (s, e) -> self#payload "%" s e
| Pmod_unpack _ | Pmod_ident _ | Pmod_constraint _ | Pmod_structure _
->
self#simple_module_expr x
method recmodule ?extension decls =
let items =
List.mapi
~f:(fun i xx ->
let { Reason_attributes.stdAttrs; docAttrs; _ } =
Reason_attributes.partitionAttributes
~partDoc:true
xx.pmb_attributes
in
let layout =
self#attach_std_item_attrs stdAttrs
@@ self#let_module_binding
(if i == 0
then add_extension_sugar "module" extension ^ " rec"
else "and")
(atom (moduleIdent xx.pmb_name))
xx.pmb_expr
in
let layoutWithDocAttrs =
self#attachDocAttrsToLayout
~stdAttrs
~docAttrs
~loc:xx.pmb_name.loc
~layout
()
in
extractLocModuleBinding xx, layoutWithDocAttrs)
decls
in
makeNonIndentedBreakingList
(groupAndPrint
~xf:(fun (_, layout) -> layout)
~getLoc:(fun (loc, _) -> loc)
~comments:self#comments
items)
method pstr_open ?extension od =
let open_prefix =
add_open_extension_sugar ~override:od.popen_override extension
in
self#attach_std_item_attrs od.popen_attributes
@@ label
~space:true
(atom open_prefix)
(self#moduleExpressionToFormattedApplicationItems od.popen_expr)
method structure ?(indent = Some 0) ?wrap structureItems =
(* We don't have any way to know if an extension is placed at the top
level by the parsetree while there's a difference syntactically (%
for structure_items/expressons and %% for top_level). This small fn
detects this particular case (structure > structure_item >
extension > value) and prints with double % *)
let structure_item item =
match item.pstr_desc with
| Pstr_extension ((extension, PStr [ item ]), attrs) ->
(match item.pstr_desc with
(* In case of a value or `external`, the extension gets inlined
`let%private a = 1` *)
| Pstr_value (rf, vb_list) ->
self#bindings ~extension (rf, vb_list)
| Pstr_primitive vd -> self#primitive_declaration ~extension vd
| Pstr_module binding ->
let bindingName =
atom ~loc:binding.pmb_name.loc (moduleIdent binding.pmb_name)
in
let module_binding =
let prefix = add_extension_sugar "module" (Some extension) in
self#let_module_binding prefix bindingName binding.pmb_expr
in
self#attach_std_item_attrs binding.pmb_attributes module_binding
| Pstr_recmodule decls -> self#recmodule ~extension decls
| Pstr_open od -> self#pstr_open ~extension od
| Pstr_type (rf, l) -> self#type_def_list ~extension rf l
| Pstr_typext te -> self#type_extension ~extension te
| Pstr_eval
( ({ pexp_desc =
Pexp_constant (Pconst_string (i, _, Some delim))
; pexp_attributes
; _
} as expr)
, _ ) ->
let { Reason_attributes.stylisticAttrs; _ } =
Reason_attributes.partitionAttributes
~allowUncurry:(Reason_heuristics.melExprCanBeUncurried expr)
pexp_attributes
in
if Reason_attributes.has_quoted_extension_attrs stylisticAttrs
then quoted_ext ~pct:"%%" extension i delim
else
self#attach_std_item_attrs
attrs
(self#payload "%%" extension (PStr [ item ]))
| _ ->
self#attach_std_item_attrs
attrs
(self#payload "%%" extension (PStr [ item ])))
| _ -> self#structure_item item
in
match structureItems with
| [] -> makeList ?wrap []
| first :: _ as structureItems ->
let last =
match List.rev structureItems with
| last :: _ -> last
| [] -> assert false
in
let loc_start = first.pstr_loc.loc_start in
let loc_end = last.pstr_loc.loc_end in
let items =
groupAndPrint
~xf:structure_item
~getLoc:(fun x -> x.pstr_loc)
~comments:self#comments
structureItems
in
source_map
~loc:{ loc_start; loc_end; loc_ghost = false }
(makeList
~postSpace:true
~break:Always_rec
?wrap
?indent
~inline:(true, false)
~sep:(SepFinal (";", ";"))
items)
(* How do modules become parsed? * let module (X: sig) = blah; * Will
not parse! (Should just make it parse to let [X:sig =]). * let module
X: sig = blah; * Becomes Pmod_constraint * let module X: sig =
(blah:sig); * Becomes Pmod_constraint .. Pmod_constraint * let module
X = blah:typ; * Becomes Pmod_constraint * let module X (Y:y) (Z:z):r
=> Q * Becomes Pmod_functor...=> Pmod_constraint
* let module X (Y:y) (Z:z):r => (Q:r2) * Probably becomes
Pmod_functor...=> (Pmod_constraint.. * Pmod_constraint)
* let (module X) = * Is a *completely* different thing
(unpacking/packing first class modules). * We should make sure this
is very well distinguished. * - Just replace all "let module" with a
new three letter keyword (mod)? * - Reserve let (module X) for
unpacking first class modules.
* See the notes about how Ppat_constraint become parsed and attempt
to unify * those as well. *)
method let_module_binding prefixText bindingName moduleExpr =
let { Reason_attributes.stdAttrs; _ } =
Reason_attributes.partitionAttributes moduleExpr.pmod_attributes
in
let argsList, return =
self#curriedFunctorPatternsAndReturnStruct moduleExpr
in
match argsList, return.pmod_desc with
(* Simple module with type constraint, no functor args. *)
| [], Pmod_constraint (unconstrainedRetTerm, ct) ->
let letPattern =
makeList
[ makeList ~postSpace:true [ atom prefixText; bindingName ]
; atom ":"
]
in
let typeConstraint = self#module_type letPattern ct in
let includingEqual =
makeList ~postSpace:true [ typeConstraint; atom "=" ]
in
formatAttachmentApplication
applicationFinalWrapping
(Some (true, includingEqual))
( [ self#moduleExpressionToFormattedApplicationItems
unconstrainedRetTerm
|> self#attach_std_item_attrs stdAttrs
]
, None )
(* Simple module with type no constraint, no functor args. *)
| [], _ ->
self#formatSimplePatternBinding
prefixText
bindingName
None
( [ self#moduleExpressionToFormattedApplicationItems return
|> self#attach_std_item_attrs stdAttrs
]
, None )
| _, _ ->
(* A functor *)
let argsWithConstraint, actualReturn =
match return.pmod_desc with
(* A functor with constrained return type: * * let module X = (A)
(B) : Ret => ... * *)
| Pmod_constraint (me, ct) ->
( [ makeTup argsList
; self#non_arrowed_module_type (atom ":") ct
]
, me )
| _ -> [ makeTup argsList ], return
in
self#wrapCurriedFunctionBinding
prefixText
~arrow:"=>"
(makeList [ bindingName; atom " =" ])
argsWithConstraint
( [ self#moduleExpressionToFormattedApplicationItems actualReturn
|> self#attach_std_item_attrs stdAttrs
]
, None )
method class_opening class_keyword name pci_virt ls =
let name = add_raw_identifier_prefix name in
let firstToken = if class_keyword then "class" else "and" in
match pci_virt, ls with
(* When no class params, it's a very simple formatting for the *
opener - no breaking. *)
| Virtual, [] -> firstToken, atom "virtual", [ atom name ]
| Concrete, [] -> firstToken, atom name, []
| Virtual, _ :: _ ->
firstToken, atom "virtual", [ atom name; self#class_params_def ls ]
| Concrete, _ :: _ ->
firstToken, atom name, [ self#class_params_def ls ]
(* TODO: TODOATTRIBUTES: Structure items don't have attributes, but each
pstr_desc *)
method structure_item term =
let item =
match term.pstr_desc with
| Pstr_eval (e, attrs) ->
let { Reason_attributes.stdAttrs; jsxAttrs; uncurried; _ } =
Reason_attributes.partitionAttributes attrs
in
if uncurried then Hashtbl.add uncurriedTable e.pexp_loc true;
let layout =
self#attach_std_item_attrs
stdAttrs
(self#unparseUnattributedExpr e)
in
(* If there was a JSX attribute BUT JSX component wasn't detected,
that JSX attribute needs to be pretty printed so it doesn't get
lost *)
(match jsxAttrs with
| [] -> layout
| _ :: _ ->
let jsxAttrNodes = List.map ~f:self#attribute jsxAttrs in
makeList ~sep:(Sep " ") (jsxAttrNodes @ [ layout ]))
| Pstr_type (_, []) -> assert false
| Pstr_type (rf, l) -> self#type_def_list rf l
| Pstr_value (rf, l) -> self#bindings (rf, l)
| Pstr_typext te -> self#type_extension te
| Pstr_exception ed ->
self#exception_declaration
{ ed.ptyexn_constructor with
pext_attributes =
ed.ptyexn_attributes @ ed.ptyexn_constructor.pext_attributes
}
| Pstr_module binding ->
let bindingName =
atom ~loc:binding.pmb_name.loc (moduleIdent binding.pmb_name)
in
let module_binding =
self#let_module_binding "module" bindingName binding.pmb_expr
in
self#attach_std_item_attrs binding.pmb_attributes module_binding
| Pstr_open od -> self#pstr_open od
| Pstr_modtype x ->
let name = atom (add_raw_identifier_prefix x.pmtd_name.txt) in
let main =
match x.pmtd_type with
| None -> makeList ~postSpace:true [ atom "module type"; name ]
| Some mt ->
let letPattern =
makeList
~postSpace:true
[ atom "module type"; name; atom "=" ]
in
self#module_type letPattern mt
in
self#attach_std_item_attrs x.pmtd_attributes main
| Pstr_class l -> self#class_declaration_list l
| Pstr_class_type l -> self#class_type_declaration_list l
| Pstr_primitive vd -> self#primitive_declaration vd
| Pstr_include incl ->
self#attach_std_item_attrs incl.pincl_attributes
@@
(* Kind of a hack *)
let moduleExpr = incl.pincl_mod in
self#moduleExpressionToFormattedApplicationItems
~prefix:"include"
moduleExpr
| Pstr_recmodule decls -> self#recmodule decls
| Pstr_attribute a -> self#floating_attribute a
| Pstr_extension (((_extension, PStr []) as extension), attrs) ->
(* Extension with attributes and without PStr gets printed
inline *)
self#attach_std_attrs attrs (self#item_extension extension)
| Pstr_extension ((extension, PStr [ item ]), attrs) ->
(match item.pstr_desc with
(* In case of a value, the extension gets inlined `let%lwt a =
1` *)
| Pstr_value (rf, l) -> self#bindings ~extension (rf, l)
| _ ->
let { Reason_attributes.stdAttrs; docAttrs; _ } =
Reason_attributes.partitionAttributes ~partDoc:true attrs
in
let item = self#structure_item item in
let layout =
self#attach_std_item_attrs ~extension stdAttrs item
in
makeList (List.map ~f:self#attribute docAttrs @ [ layout ]))
| Pstr_extension (e, a) ->
(* Notice how extensions have attributes - but not every structure
item does. *)
self#attach_std_item_attrs a (self#item_extension e)
in
source_map ~loc:term.pstr_loc item
method type_extension ?extension te =
let formatOneTypeExtStandard prepend ({ ptyext_path; _ } as te) =
let name = self#longident_loc ptyext_path in
let item = self#formatOneTypeExt prepend name (atom "+=") te in
let { Reason_attributes.stdAttrs; docAttrs; _ } =
Reason_attributes.partitionAttributes
~partDoc:true
te.ptyext_attributes
in
let layout = self#attach_std_item_attrs stdAttrs item in
self#attachDocAttrsToLayout
~stdAttrs
~docAttrs
~loc:ptyext_path.loc
~layout
()
in
let label = add_extension_sugar "type" extension in
formatOneTypeExtStandard (atom label) te
(* [allowUnguardedSequenceBodies] allows sequence expressions {} to the
right of `=>` to not be guarded in `{}` braces. *)
method case_list ?(allowUnguardedSequenceBodies = false) l =
let rec appendLabelToLast items rhs =
match items with
| hd :: [] -> label ~indent:0 ~space:true hd rhs :: []
| hd :: tl -> hd :: appendLabelToLast tl rhs
| [] -> raise (NotPossible "Cannot append to last of nothing")
in
let case_row { pc_lhs; pc_guard; pc_rhs } =
let theOrs = orList pc_lhs in
(* match x with *)
(* | AnotherReallyLongVariantName (_, _, _) *)
(* | AnotherReallyLongVariantName2 (_, _, _) when true => { *)
(* } *)
(*<sbi><X>match x with</X> *)
(* <Y>everythingElse</Y> *)
(*</sbi> *)
(* ............................................................
* : each or segment has a spaced list <> that ties its :
* : bar "|" to its pattern :
* ...:..........................................................:.....
* : : each or-patterned match is grouped in SpacedBreakableInline :
* : : : :
* v v v v
* <sbi><>|<lb><A><> FirstThingStandalone t =></A></><B>t</B></lb></></sbi>
* <sbi><>|<C> AnotherReallyLongVariantName (_, _, _)</C></>
* ^ <>|<lb><><lb><D>AnotherReallyLongVariantNam2 (_, _, _)</D> (label the last in or ptn for or and label it again for arrow)
* : ^ ^ ^ <E>when true<E></lb> =></><F>{
* : : : : </F>}</lb></sbi> ^ ^
* : : : : ^ ^ : :
* : : : : : : : :
* : : : :If there is :a WHERE : :
* : : : :an extra :label is : :
* : : : :inserted bef:ore the : :
* : : : :arrow. : : : :
* : : : :............:.....:...: :
* : : : : : :
* : : : : : :
* : : : : : :
* : : :The left side of:this final label:
* : : :uses a list to :append the arrow:
* : : :................:.....:..........:
* : : : :
* : : : :
* : : : :
* : :Final or segment is: :
* : :wrapped in lbl that: :
* : :partitions pattern : :
* : :and arrow from : :
* : :expression. : :
* : : : :
* : :...................: :
* : [orsWithWhereAndArrowOnLast] :
* : :
* :..................................:
* [row]
*)
let bar xx = makeList ~postSpace:true [ atom "|"; xx ] in
let appendWhereAndArrow p =
match pc_guard with
| None -> makeList ~postSpace:true [ p; atom "=>" ]
| Some g ->
(* when x should break as a whole - extra list added around it
to make it break as one *)
let withWhen =
label
~space:true
p
(makeList
~break:Layout.Never
~inline:(true, true)
~postSpace:true
[ label ~space:true (atom "when") (self#unparseExpr g) ])
in
makeList
~inline:(true, true)
~postSpace:true
[ withWhen; atom "=>" ]
in
let rec appendWhereAndArrowToLastOr = function
| [] -> []
| hd :: tl ->
let formattedHd = self#pattern hd in
let formattedHd =
match hd.ppat_desc with
| Ppat_constraint _ -> formatPrecedence formattedHd
| _ -> formattedHd
in
let formattedHd =
if tl == []
then appendWhereAndArrow formattedHd
else formattedHd
in
formattedHd :: appendWhereAndArrowToLastOr tl
in
let orsWithWhereAndArrowOnLast =
appendWhereAndArrowToLastOr theOrs
in
let rhs =
if allowUnguardedSequenceBodies
then
match self#under_pipe#letList pc_rhs with
(* TODO: Still render a list with located information here so
that comments (eol) are interleaved *)
| [ hd ] -> hd
(* In this case, we don't need any additional indentation,
because there aren't wrapping {} which would cause zero
indentation to look strange. *)
| lst -> makeUnguardedLetSequence lst
else self#under_pipe#unparseExpr pc_rhs
in
source_map
(* Fake shift the location to accommodate for the bar, to make sure
* the wrong comments don't make their way past the next bar. *)
~loc:
(expandLocation
~expand:(0, 0)
{ loc_start = pc_lhs.ppat_loc.loc_start
; loc_end = pc_rhs.pexp_loc.loc_end
; loc_ghost = false
})
(makeList
~break:Always_rec
~inline:(true, true)
(List.map
~f:bar
(appendLabelToLast orsWithWhereAndArrowOnLast rhs)))
in
groupAndPrint
~xf:case_row
~getLoc:(fun { pc_lhs; pc_rhs; _ } ->
{ pc_lhs.ppat_loc with loc_end = pc_rhs.pexp_loc.loc_end })
~comments:self#comments
l
(* Formats a list of a single expr param in such a way that the parens of the function or
* (poly)-variant application and the wrapping of the param stick together when the layout breaks.
* Example: `foo({a: 1, b: 2})` needs to be formatted as
* foo({
* a: 1,
* b: 2
* })
* when the line length dictates breaking. Notice how `({` and `})` 'hug'.
* Also see "isSingleArgParenApplication" which determines if
* this kind of formatting should happen. *)
method singleArgParenApplication
?(wrap = "", "")
?(uncurried = false)
es =
let lwrap, rwrap = wrap in
let lparen = lwrap ^ if uncurried then "(. " else "(" in
let rparen = ")" ^ rwrap in
match es with
| [ { pexp_attributes = []; pexp_desc = Pexp_record (l, eo); _ } ] ->
self#unparseRecord ~wrap:(lparen, rparen) l eo
| [ { pexp_attributes = []; pexp_desc = Pexp_tuple l; _ } ] ->
self#unparseSequence ~wrap:(lparen, rparen) ~construct:`Tuple l
| [ { pexp_attributes = []; pexp_desc = Pexp_array l; _ } ] ->
self#unparseSequence ~wrap:(lparen, rparen) ~construct:`Array l
| [ { pexp_attributes = []; pexp_desc = Pexp_object cs; _ } ] ->
self#classStructure ~wrap:(lparen, rparen) cs
| [ { pexp_attributes = []; pexp_desc = Pexp_extension (s, p); _ } ]
when s.txt = "mel.obj" ->
self#formatMelObjExtensionSugar ~wrap:(lparen, rparen) p
| [ ({ pexp_attributes = []; _ } as exp) ]
when is_simple_list_expr exp ->
(match view_expr exp with
| `list xs ->
self#unparseSequence ~construct:`List ~wrap:(lparen, rparen) xs
| `cons xs ->
self#unparseSequence ~construct:`ES6List ~wrap:(lparen, rparen) xs
| _ -> assert false)
| _ -> assert false
method formatSingleArgLabelApplication labelTerm rightExpr =
let layout_right =
match rightExpr with
| { pexp_desc = Pexp_let _; _ } ->
makeLetSequence ~wrap:("({", "})") (self#letList rightExpr)
| e when isSingleArgParenApplication [ rightExpr ] ->
self#singleArgParenApplication [ e ]
| { pexp_desc = Pexp_construct ({ txt = Lident "()"; _ }, _); _ } ->
(* special case unit such that we don't end up with double
parens *)
self#simplifyUnparseExpr rightExpr
| _ -> formatPrecedence (self#unparseExpr rightExpr)
in
label labelTerm layout_right
method label_x_expression_param (l, e) =
let term = self#unparseProtectedExpr e in
let param =
match l, e with
| Nolabel, _ -> term
| Labelled lbl, _
when Reason_heuristics.is_punned_labelled_expression e lbl ->
makeList [ atom namedArgSym; term ]
| Optional lbl, _
when Reason_heuristics.is_punned_labelled_expression e lbl ->
makeList [ atom namedArgSym; label term (atom "?") ]
| Labelled lbl, _ -> label (atom (namedArgSym ^ lbl ^ "=")) term
| Optional lbl, _ -> label (atom (namedArgSym ^ lbl ^ "=?")) term
in
source_map ~loc:e.pexp_loc param
method label_x_expression_params ?wrap ?(uncurried = false) xs =
match xs with
(* function applications with unit as only argument should be printed
differently * e.g. print_newline(()) should be printed as
print_newline() *)
| [ ( Nolabel
, { pexp_attributes = []
; pexp_desc = Pexp_construct ({ txt = Lident "()"; _ }, None)
; _
} )
] ->
makeList
~break:Never
?wrap
[ (if uncurried then atom "(.)" else atom "()") ]
(* The following cases provide special formatting when there's only one expr_param that is a tuple/array/list/record etc.
* e.g. foo({a: 1, b: 2})
* becomes ->
* foo({
* a: 1,
* b: 2,
* })
* when the line-length indicates breaking.
*)
| [ (Nolabel, exp) ] when isSingleArgParenApplication [ exp ] ->
self#singleArgParenApplication ?wrap ~uncurried [ exp ]
| params ->
makeTup
?wrap
~uncurried
(List.map ~f:self#label_x_expression_param params)
(* Prefix represents an optional layout. When passed it will be "prefixed" to
* the funExpr. Example, given `bar(x, y)` with prefix `foo`, we get
* foobar(x,y). When the arguments break, the closing `)` is nicely aligned
* on the height of the prefix:
* foobar(
* x,
* y,
* ) --> notice how `)` sits on the height of `foo` instead of `bar`
*
* ~wrap -> represents optional "wrapping", might be useful in context of jsx
* where braces are required:
* prop={bar( -> `{` is formatted before the funExpr
* x,
* y,
* )} -> notice how the closing brace hugs: `)}`
*)
method formatFunAppl
?(prefix = atom "")
?(wrap = "", "")
~jsxAttrs
~args
~funExpr
~applicationExpr
?(uncurried = false)
() =
let leftWrap, rightWrap = wrap in
let uncurriedApplication = uncurried in
(* If there was a JSX attribute BUT JSX component wasn't detected,
that JSX attribute needs to be pretty printed so it doesn't get
lost *)
let maybeJSXAttr = List.map ~f:self#attribute jsxAttrs in
let categorizeFunApplArgs args =
let reverseArgs = List.rev args in
match reverseArgs with
| ((_, { pexp_desc = Pexp_function (_ :: _, _, _); _ }) as callback)
:: args
when []
== List.filter
~f:(fun (_, e) ->
match e.pexp_desc with
| Pexp_function (_ :: _, _, _) -> true
| _ -> false)
args
(* default to normal formatting if there's more than one
callback *) ->
`LastArgIsCallback (callback, List.rev args)
| _ -> `NormalFunAppl args
in
let formattedFunExpr =
match funExpr.pexp_desc with
(* pipe first chain or sharpop chain as funExpr, no parens needed,
we know how to parse *)
| Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident s; _ }; _ }, _)
when requireNoSpaceFor s ->
self#unparseExpr funExpr
| Pexp_field _ -> self#unparseExpr funExpr
| _ -> self#simplifyUnparseExpr funExpr
in
let formattedFunExpr =
makeList [ prefix; atom leftWrap; formattedFunExpr ]
in
match categorizeFunApplArgs args with
| `LastArgIsCallback (callbackArg, args) ->
(* This is the following case: * Thing.map(foo, bar, baz, (abc, z)
=> * MyModuleBlah.toList(argument) *)
let argLbl, cb = callbackArg in
let { Reason_attributes.stdAttrs; uncurried; _ } =
Reason_attributes.partitionAttributes cb.pexp_attributes
in
let cbAttrs = stdAttrs in
if uncurried then Hashtbl.add uncurriedTable cb.pexp_loc true;
let cbArgs, retCb =
self#curriedPatternsAndReturnVal { cb with pexp_attributes = [] }
in
let cbArgs =
if cbAttrs != []
then
makeList
~break:IfNeed
~inline:(true, true)
~postSpace:true
(List.map ~f:self#attribute cbAttrs @ cbArgs)
else makeList cbArgs
in
let retCb, cbArgs =
match retCb.pexp_desc with
| Pexp_constraint (a, t) ->
a, makeList [ cbArgs; atom ": "; self#core_type t ]
| _ -> retCb, cbArgs
in
let theCallbackArg =
match argLbl with
| Optional s ->
makeList ([ atom namedArgSym; atom s; atom "=?" ] @ [ cbArgs ])
| Labelled s ->
makeList ([ atom namedArgSym; atom s; atom "=" ] @ [ cbArgs ])
| Nolabel -> cbArgs
in
let theFunc =
source_map
~loc:funExpr.pexp_loc
(makeList
~wrap:("", if uncurriedApplication then "(." else "(")
[ formattedFunExpr ])
in
let formattedFunAppl =
match self#letList retCb with
| [ x ] ->
(* force breaks for test assertion style callbacks, e.g. *
describe("App", () => test("math", () => Expect.expect(1 + 2)
|> toBe(3))); * should always break for readability of the
tests: * describe("App", () => * test("math", () => *
Expect.expect(1 + 2) |> toBe(3) * ) * ); *)
let forceBreak =
match funExpr.pexp_desc with
| Pexp_ident ident
when let lastIdent = Longident.last_exn ident.txt in
List.mem
lastIdent
~set:[ "test"; "describe"; "it"; "expect" ] ->
true
| _ -> false
in
let ((leftWrap, rightWrap) as wrap) = "=> ", ")" ^ rightWrap in
let wrap =
if self#should_preserve_requested_braces retCb
then leftWrap ^ "{", "}" ^ rightWrap
else wrap
in
let returnValueCallback =
makeList
~break:(if forceBreak then Always else IfNeed)
~wrap
[ x ]
in
let argsWithCallbackArgs =
List.concat
[ List.map ~f:self#label_x_expression_param args
; [ theCallbackArg ]
]
in
let left =
label
theFunc
(makeList
~pad:(uncurriedApplication, false)
~wrap:("", " ")
~break:IfNeed
~inline:(true, true)
~sep:(Sep ",")
~postSpace:true
argsWithCallbackArgs)
in
label left returnValueCallback
| xs ->
let printWidthExceeded =
Reason_heuristics.funAppCallbackExceedsWidth
~printWidth:settings.width
~args
~funExpr
()
in
if not printWidthExceeded
then
(* Thing.map(foo, bar, baz, (abc, z) =>
* MyModuleBlah.toList(argument)
* )
*
* To get this kind of formatting we need to construct the following tree:
* <Label>
* <left>Thing.map(foo, bar, baz, (abc, z)</left><right>=>
* MyModuleBlah.toList(argument)
* )</right>
* </Label>
*
* where left is
* <Label><left>Thing.map(</left></right>foo, bar, baz, (abc, z) </right></Label>
*
* The <right> part of that label could be a <List> with wrap:("", " ") break:IfNeed inline:(true, true)
* with items: "foo", "bar", "baz", "(abc, z)", separated by commas.
*
* this is also necessary to achieve the following formatting where }) hugs :
* test("my test", () => {
* let x = a + b;
* let y = z + c;
* x + y
* });
*)
let ((leftWrap, rightWrap) as wrap) =
"=> ", ")" ^ rightWrap
in
let wrap =
match
( self#should_preserve_requested_braces retCb
, self#isSeriesOfOpensFollowedByNonSequencyExpression
{ retCb with pexp_attributes = [] } )
with
| true, _ | _, false -> leftWrap ^ "{", "}" ^ rightWrap
| _ -> wrap
in
let right =
source_map
~loc:retCb.pexp_loc
(makeList
~break:Always_rec
~wrap
~sep:(SepFinal (";", ";"))
xs)
in
let argsWithCallbackArgs =
List.map ~f:self#label_x_expression_param args
@ [ theCallbackArg ]
in
let left =
label
theFunc
(makeList
~wrap:("", " ")
~break:IfNeed
~inline:(true, true)
~sep:(Sep ",")
~postSpace:true
argsWithCallbackArgs)
in
label left right
else
(* Since the heuristic says the line length is exceeded in this case,
* we conveniently format everything as
* <label><left>Thing.map(</left><right><list>
* foo,
* bar,
* baz,
* <label> <left>(abc) =></left> <right><list> {
* let x = 1;
* let y = 2;
* x + y
* }</list></right></label>
* )</list></right></label>
*)
let args =
makeList
~break:Always
~wrap:("", ")" ^ rightWrap)
~sep:commaTrail
(List.map ~f:self#label_x_expression_param args
@ [ label
~space:true
(makeList ~wrap:("", " =>") [ theCallbackArg ])
(source_map
~loc:retCb.pexp_loc
(makeLetSequence xs))
])
in
(* This will need to be (theFunc, args) *)
label theFunc args
in
maybeJSXAttr @ [ formattedFunAppl ]
| `NormalFunAppl args ->
let theFunc = source_map ~loc:funExpr.pexp_loc formattedFunExpr in
(* reset here only because [function,match,try,sequence] are lower
priority *)
(* The "expression location" might be different than the location of the actual
* function application because things like surrounding { } expand the
* parsed location (in body of while loop for example).
* We recover the most meaningful function application location we can.*)
let syntheticApplicationLocation, syntheticArgLoc =
match args with
| [] -> funExpr.pexp_loc, funExpr.pexp_loc
| _ :: _ ->
( { funExpr.pexp_loc with
loc_end = applicationExpr.pexp_loc.loc_end
}
, { funExpr.pexp_loc with
loc_start = funExpr.pexp_loc.loc_end
; loc_end = applicationExpr.pexp_loc.loc_end
} )
in
let theArgs =
self#reset#label_x_expression_params
~wrap:("", rightWrap)
~uncurried
args
in
maybeJSXAttr
@ [ source_map
~loc:syntheticApplicationLocation
(label theFunc (source_map ~loc:syntheticArgLoc theArgs))
]
end
let toplevel_phrase ppf x =
match x with
| Ptop_def s -> format_layout ppf (printer#structure s)
| Ptop_dir _ -> print_string "(* top directives not supported *)"
let case_list ppf x = List.iter ~f:(format_layout ppf) (printer#case_list x)
(* Convert a Longident to a list of strings. E.g. M.Constructor will be
["Constructor"; "M.Constructor"] Also support ".Constructor" to specify
access without a path. *)
let longident_for_arity lid =
let rec toplevel = function
| Lident s -> [ s ]
| Ldot (lid, s) ->
let append_s x = x ^ "." ^ s in
s :: List.map ~f:append_s (toplevel lid)
| Lapply (_, s) -> toplevel s
in
match lid with Lident s -> ("." ^ s) :: toplevel lid | _ -> toplevel lid
(* add expilcit_arity to a list of attributes *)
let add_explicit_arity loc attributes =
{ attr_name = { txt = "explicit_arity"; loc }
; attr_payload = PStr []
; attr_loc = loc
}
:: Reason_syntax_util.normalized_attributes "explicit_arity" attributes
(* explicit_arity_exists check if expilcit_arity exists *)
let explicit_arity_not_exists attributes =
not (Reason_syntax_util.attribute_exists "explicit_arity" attributes)
(* wrap_expr_with_tuple wraps an expression * with tuple as a sole
argument. *)
let wrap_expr_with_tuple exp = { exp with pexp_desc = Pexp_tuple [ exp ] }
(* wrap_pat_with_tuple wraps an pattern * with tuple as a sole argument. *)
let wrap_pat_with_tuple pat = { pat with ppat_desc = Ppat_tuple [ pat ] }
(* explicit_arity_constructors is a set of constructors that are known to
have * multiple arguments * *)
module StringSet = Stdlib.Set.Make (String)
let built_in_explicit_arity_constructors =
[ "Some"; "Assert_failure"; "Match_failure" ]
let explicit_arity_constructors =
StringSet.of_list
(built_in_explicit_arity_constructors
@ !configuredSettings.constructorLists)
let preprocessing_mapper =
let escape_slashes = new Reason_syntax_util.escape_stars_slashes_mapper in
object
inherit Ast_traverse.map as super
method! expression expr =
let expr =
match expr with
| { pexp_desc = Pexp_construct (lid, Some sp)
; pexp_loc
; pexp_attributes
; _
}
when List.exists
~f:(fun c -> StringSet.mem c explicit_arity_constructors)
(longident_for_arity lid.txt)
&& explicit_arity_not_exists pexp_attributes ->
{ pexp_desc = Pexp_construct (lid, Some (wrap_expr_with_tuple sp))
; pexp_loc
; pexp_attributes = add_explicit_arity pexp_loc pexp_attributes
; pexp_loc_stack = []
}
| x -> x
in
escape_slashes#expression (super#expression expr)
method! pattern pat =
let pat =
match pat with
| { ppat_desc = Ppat_construct (lid, Some (x, sp))
; ppat_loc
; ppat_attributes
; _
}
when List.exists
~f:(fun c -> StringSet.mem c explicit_arity_constructors)
(longident_for_arity lid.txt)
&& explicit_arity_not_exists ppat_attributes ->
{ ppat_desc =
Ppat_construct (lid, Some (x, wrap_pat_with_tuple sp))
; ppat_loc
; ppat_attributes = add_explicit_arity ppat_loc ppat_attributes
; ppat_loc_stack = []
}
| x -> x
in
escape_slashes#pattern (super#pattern pat)
end
let ml_to_reason_swap_operator_mapper =
new Reason_syntax_util.ml_to_reason_swap_operator_mapper
let preprocessing_mapper f a =
a |> f ml_to_reason_swap_operator_mapper |> f preprocessing_mapper
let core_type ppf x =
format_layout
ppf
(printer#core_type
(preprocessing_mapper Reason_syntax_util.apply_mapper_to_type x))
let pattern ppf x =
format_layout
ppf
(printer#pattern
(preprocessing_mapper Reason_syntax_util.apply_mapper_to_pattern x))
let signature (comments : Comment.t list) ppf x =
List.iter ~f:printer#trackComment comments;
format_layout
ppf
~comments
(printer#signature
(preprocessing_mapper Reason_syntax_util.apply_mapper_to_signature x))
let structure (comments : Comment.t list) ppf x =
List.iter ~f:printer#trackComment comments;
format_layout
ppf
~comments
(printer#structure
(preprocessing_mapper Reason_syntax_util.apply_mapper_to_structure x))
let expression ppf x =
format_layout
ppf
(printer#unparseExpr
(preprocessing_mapper Reason_syntax_util.apply_mapper_to_expr x))
let case_list = case_list
end
in
object
method core_type = Formatter.core_type
method pattern = Formatter.pattern
method signature = Formatter.signature
method structure = Formatter.structure
(* For merlin-destruct *)
method toplevel_phrase = Formatter.toplevel_phrase
method expression = Formatter.expression
method case_list = Formatter.case_list
end
================================================
FILE: src/reason-parser/reason_pprint_ast.mli
================================================
open Ppxlib
val configure :
width:int
-> assumeExplicitArity:bool
-> constructorLists:string list
-> unit
val createFormatter :
unit
-> < case_list : Format.formatter -> Parsetree.case list -> unit
; core_type : Format.formatter -> Parsetree.core_type -> unit
; expression : Format.formatter -> Parsetree.expression -> unit
; pattern : Format.formatter -> Parsetree.pattern -> unit
; signature :
Reason_comment.t list
-> Format.formatter
-> Parsetree.signature
-> unit
; structure :
Reason_comment.t list
-> Format.formatter
-> Parsetree.structure
-> unit
; toplevel_phrase : Format.formatter -> Parsetree.toplevel_phrase -> unit >
================================================
FILE: src/reason-parser/reason_recover_parser.ml
================================================
module M = Reason_multi_parser
module R =
Merlin_recovery.Make
(Reason_parser.MenhirInterpreter)
(struct
include Reason_parser_recover
let default_value loc x =
Default.default_loc := loc;
default_value x
let guide _ = false
end)
type 'a parser =
| Correct of 'a M.parser
| Recovering of 'a R.candidates * Reason_lexer.invalid_docstrings
let initial entry_point position = Correct (M.initial entry_point position)
type 'a step =
| Intermediate of 'a parser
| Success of 'a * Reason_lexer.invalid_docstrings
| Error
let step parser token =
match parser with
| Correct parser ->
(match M.step parser token with
| M.Intermediate parser -> Intermediate (Correct parser)
| M.Success (x, ds) -> Success (x, ds)
| M.Error ->
let _, loc_start, loc_end = token in
let loc = { Location.loc_start; loc_end; loc_ghost = false } in
let env, ds = M.recovery_env parser in
let message = Reason_parser_explain.message env token in
Reason_errors.raise_error (Reason_errors.Parsing_error message) loc;
Intermediate (Recovering (R.generate env, ds)))
| Recovering (candidates, ds) ->
(match token with
| Reason_parser.DOCSTRING text, startp, endp ->
let ds = Reason_lexer.add_invalid_docstring text startp endp ds in
Intermediate (Recovering (candidates, ds))
| _ ->
(match R.attempt candidates token with
| `Ok (cp, _) -> Intermediate (Correct (M.recover cp ds))
| `Accept x -> Success (x, ds)
| `Fail ->
(match token with
| Reason_parser.EOF, _, _ ->
(match candidates.final with
| None -> Error
| Some x -> Success (x, ds))
| _ -> Intermediate parser)))
================================================
FILE: src/reason-parser/reason_recover_parser.mli
================================================
type 'a parser
val initial :
(Lexing.position -> 'a Reason_parser.MenhirInterpreter.checkpoint)
-> Lexing.position
-> 'a parser
type 'a step =
| Intermediate of 'a parser
| Success of 'a * Reason_lexer.invalid_docstrings
| Error
val step : 'a parser -> Reason_parser.token Reason_lexer.positioned -> 'a step
================================================
FILE: src/reason-parser/reason_single_parser.ml
================================================
module I = Reason_parser.MenhirInterpreter
type token = Reason_parser.token
type invalid_docstrings = Reason_lexer.invalid_docstrings
module Step : sig
type 'a parser
type 'a step =
| Intermediate of 'a parser
| Success of 'a * invalid_docstrings
| Error
val initialize : 'a I.checkpoint -> 'a step
val offer : 'a parser -> token Reason_lexer.positioned -> 'a step
val add_docstring :
string
-> Lexing.position
-> Lexing.position
-> 'a parser
-> 'a parser
val recover : 'a I.checkpoint -> invalid_docstrings -> 'a parser
val recovery_env : 'a parser -> 'a I.env * invalid_docstrings
end = struct
type 'a postfix_state =
{ checkpoint : 'a I.checkpoint
; docstrings : invalid_docstrings
; fallback : 'a I.checkpoint
; postfix_ops : int
; postfix_pos : Lexing.position
}
type 'a parser =
| Normal of 'a I.checkpoint * invalid_docstrings
| After_potential_postfix of 'a postfix_state
type 'a step =
| Intermediate of 'a parser
| Success of 'a * invalid_docstrings
| Error
let mark_potential_postfix token fallback =
let string_forall f s =
let i = ref 0 in
let len = String.length s in
let valid = ref true in
while !i < len && !valid do
valid := f s.[!i];
incr i
done;
!valid
in
match token with
| Reason_parser.INFIXOP1 s, pos, _ when string_forall (( = ) '^') s ->
fun checkpoint docstrings ->
After_potential_postfix
{ checkpoint
; fallback
; docstrings
; postfix_ops = String.length s
; postfix_pos = pos
}
| _ -> fun checkpoint docstrings -> Normal (checkpoint, docstrings)
let rec offer_postfix count pos = function
| (I.Shifting _ | I.AboutToReduce _) as checkpoint ->
offer_postfix count pos (I.resume checkpoint)
| I.InputNeeded _ as checkpoint ->
if count <= 0
then checkpoint
else
let pos_cnum = pos.Lexing.pos_cnum in
let pos' = { pos with Lexing.pos_cnum = pos_cnum + 1 } in
offer_postfix
(count - 1)
pos'
(I.offer checkpoint (Reason_parser.POSTFIXOP "^", pos, pos'))
| other -> other
let rec step mark_potential_postfix safepoint docstrings = function
| (I.Shifting _ | I.AboutToReduce _) as checkpoint ->
step mark_potential_postfix safepoint docstrings (I.resume checkpoint)
| I.InputNeeded _ as checkpoint ->
Intermediate (mark_potential_postfix checkpoint docstrings)
| I.Accepted x -> Success (x, docstrings)
| I.Rejected | I.HandlingError _ -> Error
let offer parser token =
match parser with
| Normal (checkpoint, docstrings) ->
step
(mark_potential_postfix token checkpoint)
checkpoint
docstrings
(I.offer checkpoint token)
| After_potential_postfix r ->
(match
step
(mark_potential_postfix token r.checkpoint)
r.checkpoint
r.docstrings
(I.offer r.checkpoint token)
with
| Error ->
(* Try applying postfix operators on fallback parser *)
(match offer_postfix r.postfix_ops r.postfix_pos r.fallback with
| I.InputNeeded _ as checkpoint ->
step
(mark_potential_postfix token checkpoint)
checkpoint
r.docstrings
(I.offer checkpoint token)
| _ -> Error)
| result -> result)
let add_docstring text startp endp parser =
match parser with
| Normal (checkpoint, docstrings) ->
let docstrings =
Reason_lexer.add_invalid_docstring text startp endp docstrings
in
Normal (checkpoint, docstrings)
| After_potential_postfix r ->
let docstrings =
Reason_lexer.add_invalid_docstring text startp endp r.docstrings
in
After_potential_postfix { r with docstrings }
let initialize checkpoint =
step
(fun parser ds -> Normal (parser, ds))
checkpoint
Reason_lexer.empty_invalid_docstrings
checkpoint
let recover cp ds =
(match cp with I.InputNeeded _ -> () | _ -> assert false);
Normal (cp, ds)
let recovery_env parser =
let cp, ds =
match parser with
| Normal (cp, ds) -> cp, ds
| After_potential_postfix r -> r.checkpoint, r.docstrings
in
match cp with I.InputNeeded env -> env, ds | _ -> assert false
end
type 'a parser = 'a Step.parser
type 'a step = 'a Step.step =
| Intermediate of 'a parser
| Success of 'a * invalid_docstrings
| Error
let initial entry position =
match Step.initialize (entry position) with
| Step.Intermediate parser -> parser
| _ -> assert false
let rec offer_many parser = function
| [] -> Step.Intermediate parser
| [ token ] -> Step.offer parser token
| token :: tokens ->
(match Step.offer parser token with
| Step.Intermediate parser -> offer_many parser tokens
| other -> other)
(* Logic for inserting ';' *)
let try_insert_semi_on = function
| Reason_parser.LET | Reason_parser.TYPE | Reason_parser.MODULE
| Reason_parser.OPEN | Reason_parser.EXCEPTION | Reason_parser.INCLUDE
| Reason_parser.DOCSTRING _ | Reason_parser.LIDENT _ | Reason_parser.UIDENT _
| Reason_parser.IF | Reason_parser.WHILE | Reason_parser.FOR
| Reason_parser.SWITCH | Reason_parser.TRY | Reason_parser.ASSERT
| Reason_parser.EXTERNAL | Reason_parser.LAZY | Reason_parser.LBRACKETAT ->
true
| _ -> false
(* Logic for splitting '=?...' operators into '=' '?' '...' *)
let advance p n = { p with Lexing.pos_cnum = p.Lexing.pos_cnum + n }
let rec split_greaters acc pcur = function
| '>' :: tl ->
let pnext = advance pcur 1 in
split_greaters ((Reason_parser.GREATER, pcur, pnext) :: acc) pnext tl
| nonGts -> List.rev acc, nonGts, pcur
let common_remaining_infix_token pcur =
let pnext = advance pcur 1 in
function
| [ '-' ] -> Some (Reason_parser.MINUS, pcur, pnext)
| [ '-'; '.' ] -> Some (Reason_parser.MINUSDOT, pcur, advance pnext 1)
| [ '+' ] -> Some (Reason_parser.PLUS, pcur, pnext)
| [ '+'; '.' ] -> Some (Reason_parser.PLUSDOT, pcur, advance pnext 1)
| [ '!' ] -> Some (Reason_parser.BANG, pcur, pnext)
| [ '>' ] -> Some (Reason_parser.GREATER, pcur, pnext)
| [ '<' ] -> Some (Reason_parser.LESS, pcur, pnext)
| _ -> None
let rec decompose_token pos0 split =
let pcur = advance pos0 1 in
let pnext = advance pos0 2 in
match split with
(* Empty token is a valid decomposition *)
| [] -> None
| '=' :: tl ->
let eq = Reason_parser.EQUAL, pcur, pnext in
let revFirstTwo, tl, pcur, _pnext =
match tl with
| '?' :: tlTl ->
( [ Reason_parser.QUESTION, pcur, pnext; eq ]
, tlTl
, pnext
, advance pnext 1 )
| _ -> [ eq ], tl, pcur, pnext
in
if tl == []
then Some (List.rev revFirstTwo)
else (
match common_remaining_infix_token pcur tl with
| None -> None
| Some r -> Some (List.rev (r :: revFirstTwo)))
(* For type parameters type t<+'a> = .. *)
| '<' :: tl ->
let less = [ Reason_parser.LESS, pcur, pnext ] in
if tl == []
then Some less
else (
match common_remaining_infix_token pcur tl with
| None ->
None (* Couldn't parse the non-empty tail - invalidates whole thing *)
| Some r -> Some (List.rev (r :: less)))
| '>' :: _tl ->
(* Recurse to take advantage of all the logic in case the remaining
* begins with an equal sign. *)
let gt_tokens, rest_split, prest = split_greaters [] pcur split in
if rest_split == []
then Some gt_tokens
else (
match decompose_token prest rest_split with
| None ->
None (* Couldn't parse the non-empty tail - invalidates whole thing *)
| Some r -> Some (List.rev gt_tokens @ r))
| _ -> None
let rec init_tailrec_aux acc i n f =
if i >= n then acc else init_tailrec_aux (f i :: acc) (i + 1) n f
let list_init len f = List.rev (init_tailrec_aux [] 0 len f)
let explode s = list_init (String.length s) (String.get s)
let try_split_label (tok_kind, pos0, _posn) =
match tok_kind with
| Reason_parser.INFIXOP0 s ->
(match decompose_token pos0 (explode s) with None -> [] | Some l -> l)
| _ -> []
(* Logic for attempting to consume a token and try alternatives on failure *)
let step parser token =
match Step.offer parser token with
| (Success _ | Intermediate _) as step -> step
| Error ->
let try_alternative_tokens = function
| [] -> Error
| tokens ->
(match offer_many parser tokens with
| (Step.Intermediate _ | Step.Success _) as result -> result
(* Alternative failed... Return original failure *)
| Step.Error -> Error)
in
let alternative =
match token with
| tok_kind, pos, _ when try_insert_semi_on tok_kind ->
try_alternative_tokens [ Reason_parser.SEMI, pos, pos; token ]
| _ -> try_alternative_tokens (try_split_label token)
in
(match alternative, token with
| Error, (Reason_parser.DOCSTRING text, startp, endp) ->
Intermediate (Step.add_docstring text startp endp parser)
| _ -> alternative)
(* Interface for recovery *)
let recover = Step.recover
let recovery_env = Step.recovery_env
================================================
FILE: src/reason-parser/reason_single_parser.mli
================================================
type 'a parser
val initial :
(Lexing.position -> 'a Reason_parser.MenhirInterpreter.checkpoint)
-> Lexing.position
-> 'a parser
type 'a step =
| Intermediate of 'a parser
| Success of 'a * Reason_lexer.invalid_docstrings
| Error
val step : 'a parser -> Reason_parser.token Reason_lexer.positioned -> 'a step
(* Interface for recovery *)
val recover :
'a Reason_parser.MenhirInterpreter.checkpoint
-> Reason_lexer.invalid_docstrings
-> 'a parser
val recovery_env :
'a parser
-> 'a Reason_parser.MenhirInterpreter.env * Reason_lexer.invalid_docstrings
================================================
FILE: src/reason-parser/reason_syntax_util.ml
================================================
open Ppxlib
(* Rename labels in function definition/application and records *)
let rename_labels = ref false
(** Check to see if the string `s` is made up of `keyword` and zero or more
trailing `_` characters. *)
let potentially_conflicts_with ~keyword s =
let s_length = String.length s in
let keyword_length = String.length keyword in
(* It can't be a match if s is shorter than keyword *)
s_length >= keyword_length
&&
try
(* Ensure s starts with keyword... *)
for i = 0 to keyword_length - 1 do
if keyword.[i] <> s.[i] then raise Exit
done;
(* ...and contains nothing else except trailing _ characters *)
for i = keyword_length to s_length - 1 do
if s.[i] <> '_' then raise Exit
done;
(* If we've made it this far there's a potential conflict *)
true
with
| Exit -> false
(** Add/remove an appropriate suffix when mangling potential keywords *)
let string_add_suffix x = x ^ "_"
let string_drop_suffix x = String.sub x ~pos:0 ~len:(String.length x - 1)
(** What do these *_swap functions do? Here's an example: Reason code uses `!`
for logical not, while ocaml uses `not`. So, for converting between reason
and ocaml syntax, ocaml `not` converts to `!`, reason `!` converts to
`not`.
In more complicated cases where a reserved keyword exists in one syntax but
not the other, these functions translate any potentially conflicting
identifier into the same identifier with a suffix attached, or remove the
suffix when converting back. Two examples:
reason to ocaml:
pub: invalid in reason to begin with
pub_: pub
pub__: pub_
ocaml to reason:
pub: pub_
pub_: pub__
pub__: pub___
=====
reason to ocaml:
match: match_
match_: match__
match__: match___
ocaml to reason:
match: invalid in ocaml to begin with
match_: match
match__: match_
*)
let reason_to_ml_swap = function
| "!" -> "not"
| "^" -> "!"
| "++" -> "^"
| "===" -> "=="
| "==" -> "="
(* ===\/ and !==\/ are not representable in OCaml but
* representable in Reason
*)
| "\\!==" -> "!=="
| "\\===" -> "==="
| "!=" -> "<>"
| "!==" -> "!="
| x
when potentially_conflicts_with ~keyword:"match" x
|| potentially_conflicts_with ~keyword:"method" x
|| potentially_conflicts_with ~keyword:"private" x
|| potentially_conflicts_with ~keyword:"not" x ->
string_add_suffix x
| x
when potentially_conflicts_with ~keyword:"switch_" x
|| potentially_conflicts_with ~keyword:"pub_" x
|| potentially_conflicts_with ~keyword:"pri_" x ->
string_drop_suffix x
| everything_else -> everything_else
let ml_to_reason_swap = function
| "not" -> "!"
| "!" -> "^"
| "^" -> "++"
| "==" -> "==="
| "=" -> "=="
(* ===\/ and !==\/ are not representable in OCaml but
* representable in Reason
*)
| "!==" -> "\\!=="
| "===" -> "\\==="
| "<>" -> "!="
| "!=" -> "!=="
| x
when potentially_conflicts_with ~keyword:"match_" x
|| potentially_conflicts_with ~keyword:"method_" x
|| potentially_conflicts_with ~keyword:"private_" x
|| potentially_conflicts_with ~keyword:"not_" x ->
string_drop_suffix x
| x
when potentially_conflicts_with ~keyword:"switch" x
|| potentially_conflicts_with ~keyword:"pub" x
|| potentially_conflicts_with ~keyword:"pri" x ->
string_add_suffix x
| everything_else -> everything_else
let escape_string str =
let buf = Buffer.create (String.length str) in
String.iter
~f:(fun c ->
match c with
| '\t' -> Buffer.add_string buf "\\t"
| '\r' -> Buffer.add_string buf "\\r"
| '\n' -> Buffer.add_string buf "\\n"
| '\\' -> Buffer.add_string buf "\\\\"
| '"' -> Buffer.add_string buf "\\\""
| c when c < ' ' -> Buffer.add_string buf (Char.escaped c)
| c -> Buffer.add_char buf c)
str;
Buffer.contents buf
(*
UTF-8 characters are encoded like this (most editors are UTF-8)
0xxxxxxx (length 1)
110xxxxx 10xxxxxx (length 2)
1110xxxx 10xxxxxx 10xxxxxx (length 3)
11110xxx 10xxxxxx 10xxxxxx 10xxxxxx (length 4)
Numbers over 127 cannot be encoded in UTF in a single byte, so they use two
bytes. That means we can use any characters between 128-255 to encode special
characters that would never be written by the user and thus never be confused
for our special formatting characters.
*)
(* Logic for handling special behavior that only happens if things break. We
use characters that will never appear in the printed output if actually
written in source code. The OCaml formatter will replace them with the escaped
versions When moving to a new formatter, the formatter may *not* escape these
an in that case we need the formatter to accept blacklists of characters to
escape, but more likely is that the new formatter allows us to do these kinds
of if-break logic without writing out special characters for post-processing.
*)
module TrailingCommaMarker = struct
(* TODO: You can detect failed parsings by *NOT* omitting the final comma *ever*. *)
(* A trailing comma will only be rendered if it is not immediately
* followed by a closing paren, bracket, or brace *)
let char = Char.chr 249 (* ˘ *)
let string = String.make 1 char
end
(* Special character marking the end of a line. Nothing should be printed
* after this marker. Example usage: // comments shouldn't have content printed
* at the end of the comment. By attaching an EOLMarker.string at the end of the
* comment our postprocessing step will ensure a linebreak at the position
* of the marker. *)
module EOLMarker = struct
let char = Char.chr 248
let string = String.make 1 char
end
(** [is_prefixed prefix i str] checks if prefix is the prefix of str
* starting from position i
*)
let is_prefixed prefix str i =
let len = String.length prefix in
let j = ref 0 in
while
!j < len && String.unsafe_get prefix !j = String.unsafe_get str (i + !j)
do
incr j
done;
!j = len
(**
* pick_while returns a tuple where first element is longest prefix (possibly empty) of the list of elements that satisfy p
* and second element is the remainder of the list
*)
let rec pick_while p = function
| [] -> [], []
| hd :: tl when p hd ->
let satisfied, not_satisfied = pick_while p tl in
hd :: satisfied, not_satisfied
| l -> [], l
(** [find_substring sub str i]
returns the smallest [j >= i] such that [sub = str.[j..length sub - 1]]
raises [Not_found] if there is no such j
behavior is not defined if [sub] is the empty string
*)
let find_substring sub str i =
let len = String.length str - String.length sub in
let found = ref false
and i = ref i in
while (not !found) && !i <= len do
if is_prefixed sub str !i then found := true else incr i
done;
if not !found then raise Not_found;
!i
(** [replace_string old_str new_str str] replaces old_str to new_str in str *)
let replace_string old_str new_str str =
match find_substring old_str str 0 with
| exception Not_found -> str
| occurrence ->
let buffer = Buffer.create (String.length str + 15) in
let rec loop i j =
Buffer.add_substring buffer str i (j - i);
Buffer.add_string buffer new_str;
let i = j + String.length old_str in
match find_substring old_str str i with
| j -> loop i j
| exception Not_found ->
Buffer.add_substring buffer str i (String.length str - i)
in
loop 0 occurrence;
Buffer.contents buffer
(* This is lifted from
https://github.com/bloomberg/bucklescript/blob/14d94bb9c7536b4c5f1208c8e8cc715ca002853d/jscomp/ext/ext_string.ml#L32
Thanks @bobzhang and @hhugo! *)
let split_by ?(keep_empty = false) is_delim str =
let len = String.length str in
let rec loop acc last_pos pos =
if pos = -1
then
if last_pos = 0 && not keep_empty
then
(* {[ split " test_unsafe_obj_ffi_ppx.cmi" ~keep_empty:false ' ']} *)
acc
else String.sub str ~pos:0 ~len:last_pos :: acc
else if is_delim str.[pos]
then
let new_len = last_pos - pos - 1 in
if new_len <> 0 || keep_empty
then
let v = String.sub str ~pos:(pos + 1) ~len:new_len in
loop (v :: acc) pos (pos - 1)
else loop acc pos (pos - 1)
else loop acc last_pos (pos - 1)
in
loop [] len (len - 1)
let rec trim_right_idx str idx =
if idx = -1
then 0
else
match String.get str idx with
| '\t' | ' ' | '\n' | '\r' -> trim_right_idx str (idx - 1)
| _ -> idx + 1
let trim_right str =
let length = String.length str in
if length = 0
then ""
else
let index = trim_right_idx str (length - 1) in
if index = 0
then ""
else if index = length
then str
else String.sub str ~pos:0 ~len:index
let processLine line =
let rightTrimmed = trim_right line in
let trimmedLen = String.length rightTrimmed in
if trimmedLen = 0
then rightTrimmed
else
let segments =
split_by
~keep_empty:false
(fun c -> c = TrailingCommaMarker.char)
rightTrimmed
in
(* Now we concat the portions back together without any trailing comma
markers - except we detect if there was a final trailing comma marker
which we know must be before a newline so we insert a regular comma. This
achieves "intelligent" trailing commas. *)
let hadTrailingCommaMarkerBeforeNewline =
String.get rightTrimmed (trimmedLen - 1) = TrailingCommaMarker.char
in
let almostEverything = String.concat ~sep:"" segments in
let lineBuilder =
if hadTrailingCommaMarkerBeforeNewline
then almostEverything ^ ","
else almostEverything
in
(* Ensure EOLMarker.char is replaced by a newline *)
split_by ~keep_empty:false (fun c -> c = EOLMarker.char) lineBuilder
|> List.map ~f:trim_right
|> String.concat ~sep:"\n"
let processLineEndingsAndStarts str =
split_by ~keep_empty:true (fun x -> x = '\n') str
|> List.map ~f:processLine
|> String.concat ~sep:"\n"
|> String.trim
let isLineComment str =
(* true iff the first \n is the last character *)
match String.index str '\n' with
| exception Not_found -> false
| n -> n = String.length str - 1
let map_lident f lid =
let swapped =
match lid.txt with
| Lident s -> Lident (f s)
| Ldot (longPrefix, s) -> Ldot (longPrefix, f s)
| Lapply (y, s) -> Lapply (y, s)
in
{ lid with txt = swapped }
let map_arg_label f = function
| Nolabel -> Nolabel
| Labelled lbl -> Labelled (f lbl)
| Optional lbl -> Optional (f lbl)
let map_class_expr f class_expr =
{ class_expr with
pcl_desc =
(match class_expr.pcl_desc with
| Pcl_constr (lid, ts) -> Pcl_constr (map_lident f lid, ts)
| e -> e)
}
let map_class_type f class_type =
{ class_type with
pcty_desc =
(match class_type.pcty_desc with
| Pcty_constr (lid, ct) -> Pcty_constr (map_lident f lid, ct)
| Pcty_arrow (arg_lbl, ct, cls_type) ->
Pcty_arrow (map_arg_label f arg_lbl, ct, cls_type)
| x -> x)
}
let map_core_type f typ =
{ typ with
ptyp_desc =
(match typ.ptyp_desc with
| Ptyp_var var -> Ptyp_var (f var)
| Ptyp_arrow (lbl, t1, t2) ->
let lbl' =
match lbl with
| Labelled s when !rename_labels -> Labelled (f s)
| Optional s when !rename_labels -> Optional (f s)
| lbl -> lbl
in
Ptyp_arrow (lbl', t1, t2)
| Ptyp_constr (lid, typs) -> Ptyp_constr (map_lident f lid, typs)
| Ptyp_object (fields, closed_flag) when !rename_labels ->
Ptyp_object
( List.map
~f:(function
| { pof_desc = Otag (s, typ); _ } as pof ->
{ pof with pof_desc = Otag ({ s with txt = f s.txt }, typ) }
| other -> other)
fields
, closed_flag )
| Ptyp_class (lid, typs) -> Ptyp_class (map_lident f lid, typs)
| Ptyp_alias (typ, s) -> Ptyp_alias (typ, { s with txt = f s.txt })
| Ptyp_variant (rfs, closed, lbls) ->
Ptyp_variant
( List.map
~f:(function
| { prf_desc = Rtag (lbl, b, cts); _ } as prf ->
{ prf with
prf_desc = Rtag ({ lbl with txt = f lbl.txt }, b, cts)
}
| t -> t)
rfs
, closed
, lbls )
| Ptyp_poly (vars, typ) ->
Ptyp_poly (List.map ~f:(fun li -> { li with txt = f li.txt }) vars, typ)
| Ptyp_package (lid, typs) ->
Ptyp_package
( map_lident f lid
, List.map ~f:(fun (lid, typ) -> map_lident f lid, typ) typs )
| other -> other)
}
(* class supery= Ppxlib.Ast_traverse.map *)
(** identifier_mapper maps all identifiers in an AST with a mapping function f
this is used by swap_operator_mapper right below, to traverse the whole AST
and swapping the symbols listed above.
*)
class identifier_mapper f =
let map_fields fields =
List.map ~f:(fun (lid, x) -> map_lident f lid, x) fields
in
let map_name ({ txt; _ } as name) = { name with txt = f txt } in
let map_lid lid = map_lident f lid in
let map_label label = map_arg_label f label in
object
inherit Ast_traverse.map as super
method! expression (expr : Parsetree.expression) =
let expr =
match expr with
| { pexp_desc = Pexp_ident lid; _ } ->
{ expr with pexp_desc = Pexp_ident (map_lid lid) }
| { pexp_desc = Pexp_function (params, constraint_, body); _ } ->
let new_params =
List.map
~f:(fun param ->
match param with
| { pparam_desc = Pparam_val (lbl, eo, pat); _ }
when !rename_labels ->
{ param with
pparam_desc = Pparam_val (map_label lbl, eo, pat)
}
| { pparam_desc = Pparam_newtype s; _ } ->
{ param with
pparam_desc = Pparam_newtype { s with txt = f s.txt }
}
| _ -> param)
params
in
{ expr with
pexp_desc = Pexp_function (new_params, constraint_, body)
}
| { pexp_desc = Pexp_apply (e, args); _ } when !rename_labels ->
{ expr with
pexp_desc =
Pexp_apply
(e, List.map ~f:(fun (label, e) -> map_label label, e) args)
}
| { pexp_desc = Pexp_variant (s, e); _ } ->
{ expr with pexp_desc = Pexp_variant (f s, e) }
| { pexp_desc = Pexp_record (fields, closed); _ } when !rename_labels ->
{ expr with pexp_desc = Pexp_record (map_fields fields, closed) }
| { pexp_desc = Pexp_field (e, lid); _ } when !rename_labels ->
{ expr with pexp_desc = Pexp_field (e, map_lid lid) }
| { pexp_desc = Pexp_setfield (e1, lid, e2); _ } when !rename_labels ->
{ expr with pexp_desc = Pexp_setfield (e1, map_lid lid, e2) }
| { pexp_desc = Pexp_send (e, s); _ } ->
{ expr with pexp_desc = Pexp_send (e, { s with txt = f s.txt }) }
| { pexp_desc = Pexp_new lid; _ } ->
{ expr with pexp_desc = Pexp_new (map_lid lid) }
| { pexp_desc = Pexp_setinstvar (name, e); _ } ->
{ expr with pexp_desc = Pexp_setinstvar (map_name name, e) }
| { pexp_desc = Pexp_override name_exp_list; _ } ->
let name_exp_list =
List.map ~f:(fun (name, e) -> map_name name, e) name_exp_list
in
{ expr with pexp_desc = Pexp_override name_exp_list }
| { pexp_desc = Pexp_newtype (s, e); _ } ->
{ expr with pexp_desc = Pexp_newtype ({ s with txt = f s.txt }, e) }
| _ -> expr
in
super#expression expr
method! pattern pat =
let pat =
match pat with
| { ppat_desc = Ppat_var name; _ } ->
{ pat with ppat_desc = Ppat_var (map_name name) }
| { ppat_desc = Ppat_alias (p, name); _ } ->
{ pat with ppat_desc = Ppat_alias (p, map_name name) }
| { ppat_desc = Ppat_variant (s, po); _ } ->
{ pat with ppat_desc = Ppat_variant (f s, po) }
| { ppat_desc = Ppat_record (fields, closed); _ } when !rename_labels ->
{ pat with ppat_desc = Ppat_record (map_fields fields, closed) }
| { ppat_desc = Ppat_type lid; _ } ->
{ pat with ppat_desc = Ppat_type (map_lid lid) }
| _ -> pat
in
super#pattern pat
method! value_description desc =
let desc' = { desc with pval_name = map_name desc.pval_name } in
super#value_description desc'
method! type_declaration type_decl =
let type_decl' =
{ type_decl with ptype_name = map_name type_decl.ptype_name }
in
let type_decl'' =
match type_decl'.ptype_kind with
| Ptype_record lst when !rename_labels ->
{ type_decl' with
ptype_kind =
Ptype_record
(List.map
~f:(fun lbl -> { lbl with pld_name = map_name lbl.pld_name })
lst)
}
| _ -> type_decl'
in
super#type_declaration type_decl''
method! core_type typ = super#core_type (map_core_type f typ)
method! class_declaration class_decl =
let class_decl' =
{ class_decl with
pci_name = map_name class_decl.pci_name
; pci_expr = map_class_expr f class_decl.pci_expr
}
in
super#class_declaration class_decl'
method! class_field class_field =
let class_field_desc' =
match class_field.pcf_desc with
| Pcf_inherit (ovf, e, lo) -> Pcf_inherit (ovf, map_class_expr f e, lo)
| Pcf_val (lbl, mut, kind) ->
Pcf_val ({ lbl with txt = f lbl.txt }, mut, kind)
| Pcf_method (lbl, priv, kind) ->
Pcf_method ({ lbl with txt = f lbl.txt }, priv, kind)
| x -> x
in
super#class_field { class_field with pcf_desc = class_field_desc' }
method! class_type_field class_type_field =
let class_type_field_desc' =
match class_type_field.pctf_desc with
| Pctf_inherit class_type -> Pctf_inherit (map_class_type f class_type)
| Pctf_val (lbl, mut, vf, ct) ->
Pctf_val ({ lbl with txt = f lbl.txt }, mut, vf, ct)
| Pctf_method (lbl, pf, vf, ct) ->
Pctf_method ({ lbl with txt = f lbl.txt }, pf, vf, ct)
| x -> x
in
super#class_type_field
{ class_type_field with pctf_desc = class_type_field_desc' }
method! class_type_declaration class_type_decl =
let class_type_decl' =
{ class_type_decl with pci_name = map_name class_type_decl.pci_name }
in
super#class_type_declaration class_type_decl'
method! module_type_declaration module_type_decl =
let module_type_decl' =
{ module_type_decl with
pmtd_name = map_name module_type_decl.pmtd_name
}
in
super#module_type_declaration module_type_decl'
end
let remove_stylistic_attrs_mapper_maker =
object
inherit Ast_traverse.map as super
method! expression expr =
let { Reason_attributes.stylisticAttrs
; arityAttrs
; docAttrs
; stdAttrs
; jsxAttrs
; _
}
=
Reason_attributes.partitionAttributes
~allowUncurry:false
expr.pexp_attributes
in
let expr =
if stylisticAttrs != []
then
{ expr with
pexp_attributes = arityAttrs @ docAttrs @ stdAttrs @ jsxAttrs
}
else expr
in
super#expression expr
method! pattern pat =
let { Reason_attributes.stylisticAttrs
; arityAttrs
; docAttrs
; stdAttrs
; jsxAttrs
; _
}
=
Reason_attributes.partitionAttributes
~allowUncurry:false
pat.ppat_attributes
in
let pat =
if stylisticAttrs != []
then
{ pat with
ppat_attributes = arityAttrs @ docAttrs @ stdAttrs @ jsxAttrs
}
else pat
in
super#pattern pat
end
let escape_stars_slashes str =
if String.contains str '/'
then
replace_string "/*" "/\\*"
@@ replace_string "*/" "*\\/"
@@ replace_string "//" "/\\/"
@@ str
else str
let remove_stylistic_attrs_mapper = remove_stylistic_attrs_mapper_maker
let let_monad_symbols =
[ '$'; '&'; '*'; '+'; '-'; '/'; '<'; '='; '>'; '@'; '^'; '|'; '.'; '!' ]
let is_letop s =
String.length s > 3
&& s.[0] = 'l'
&& s.[1] = 'e'
&& s.[2] = 't'
&& List.mem s.[3] ~set:let_monad_symbols
let is_andop s =
String.length s > 3
&& s.[0] = 'a'
&& s.[1] = 'n'
&& s.[2] = 'd'
&& List.mem s.[3] ~set:let_monad_symbols
(* Don't need to backport past 4.08 *)
let backport_letopt_mapper = new Ast_traverse.map
let expand_letop_identifier s = s
let compress_letop_identifier s = s
(** escape_stars_slashes_mapper escapes all stars and slashes in an AST *)
class escape_stars_slashes_mapper =
object
inherit identifier_mapper escape_stars_slashes
end
(* To be used in parser, transform a token into an ast node with different
identifier *)
class reason_to_ml_swap_operator_mapper =
object
inherit identifier_mapper reason_to_ml_swap
end
(* To be used in printer, transform an ast node into a token with different
identifier *)
class ml_to_reason_swap_operator_mapper =
object
inherit identifier_mapper ml_to_reason_swap
end
(* attribute_equals tests an attribute is txt *)
let attribute_equals to_compare = function
| { attr_name = { txt; _ }; _ } -> txt = to_compare
(* attribute_exists tests if an attribute exists in a list *)
let attribute_exists txt attributes =
List.exists ~f:(attribute_equals txt) attributes
(* conflicted_attributes tests if both attribute1 and attribute2
* exist
*)
let attributes_conflicted attribute1 attribute2 attributes =
attribute_exists attribute1 attributes
&& attribute_exists attribute2 attributes
(* normalized_attributes removes attribute from a list of attributes *)
let normalized_attributes attribute attributes =
List.filter ~f:(fun x -> not (attribute_equals attribute x)) attributes
(* apply_mapper family applies an ast_mapper to an ast *)
let apply_mapper_to_structure mapper s = mapper#structure s
let apply_mapper_to_signature mapper s = mapper#signature s
let apply_mapper_to_type mapper s = mapper#core_type s
let apply_mapper_to_expr mapper s = mapper#expression s
let apply_mapper_to_pattern mapper s = mapper#pattern s
let apply_mapper_to_toplevel_phrase mapper toplevel_phrase =
match toplevel_phrase with
| Ptop_def x -> Ptop_def (apply_mapper_to_structure mapper x)
| x -> x
let apply_mapper_to_use_file mapper use_file =
List.map ~f:(apply_mapper_to_toplevel_phrase mapper) use_file
let map_first f = function
| [] -> invalid_arg "Syntax_util.map_first: empty list"
| x :: xs -> f x :: xs
let map_last f l =
match List.rev l with
| [] -> invalid_arg "Syntax_util.map_last: empty list"
| x :: xs -> List.rev (f x :: xs)
let location_is_before loc1 loc2 =
let open Location in
loc1.loc_end.Lexing.pos_cnum <= loc2.loc_start.Lexing.pos_cnum
let location_contains loc1 loc2 =
let open Location in
loc1.loc_start.Lexing.pos_cnum <= loc2.loc_start.Lexing.pos_cnum
&& loc1.loc_end.Lexing.pos_cnum >= loc2.loc_end.Lexing.pos_cnum
let split_compiler_error (err : Location.Error.t) =
( Location.Error.get_location err
, Format.asprintf "%s" (Location.Error.message err) )
let explode_str str =
let rec loop acc i = if i < 0 then acc else loop (str.[i] :: acc) (i - 1) in
loop [] (String.length str - 1)
module Clflags = Ocaml_common.Clflags
let parse_lid s =
let unflatten l =
match l with
| [] -> None
| hd :: tl ->
Some (List.fold_left ~f:(fun p s -> Ldot (p, s)) ~init:(Lident hd) tl)
in
match unflatten (String.split_on_char ~sep:'.' s) with
| Some lid -> lid
| None ->
failwith (Format.asprintf "parse_lid: unable to parse '%s' to longident" s)
================================================
FILE: src/reason-parser/reason_syntax_util.mli
================================================
open Ppxlib
val ml_to_reason_swap : string -> string
val escape_string : string -> string
val reason_to_ml_swap : string -> string
module TrailingCommaMarker : sig
val char : char
val string : string
end
module EOLMarker : sig
val char : char
val string : string
end
val pick_while : ('a -> bool) -> 'a list -> 'a list * 'a list
val split_by : ?keep_empty:bool -> (char -> bool) -> string -> string list
val processLineEndingsAndStarts : string -> string
val isLineComment : string -> bool
val remove_stylistic_attrs_mapper : Ast_traverse.map
val is_letop : string -> bool
val is_andop : string -> bool
val compress_letop_identifier : string -> string
val expand_letop_identifier : string -> string
val backport_letopt_mapper : Ast_traverse.map
val escape_stars_slashes : string -> string
class escape_stars_slashes_mapper : Ast_traverse.map
class reason_to_ml_swap_operator_mapper : Ast_traverse.map
class ml_to_reason_swap_operator_mapper : Ast_traverse.map
val attribute_exists : string -> Parsetree.attributes -> bool
val attributes_conflicted : string -> string -> Parsetree.attributes -> bool
val normalized_attributes :
string
-> Parsetree.attributes
-> Parsetree.attributes
val apply_mapper_to_structure :
Ast_traverse.map
-> Parsetree.structure
-> Parsetree.structure
val apply_mapper_to_signature :
Ast_traverse.map
-> Parsetree.signature
-> Parsetree.signature
val apply_mapper_to_type :
Ast_traverse.map
-> Parsetree.core_type
-> Parsetree.core_type
val apply_mapper_to_expr :
Ast_traverse.map
-> Parsetree.expression
-> Parsetree.expression
val apply_mapper_to_pattern :
Ast_traverse.map
-> Parsetree.pattern
-> Parsetree.pattern
val apply_mapper_to_toplevel_phrase :
Ast_traverse.map
-> Parsetree.toplevel_phrase
-> Parsetree.toplevel_phrase
val apply_mapper_to_use_file :
Ast_traverse.map
-> Parsetree.toplevel_phrase list
-> Parsetree.toplevel_phrase list
val map_first : ('a -> 'a) -> 'a list -> 'a list
val map_last : ('a -> 'a) -> 'a list -> 'a list
val location_is_before : Location.t -> Location.t -> bool
val location_contains : Location.t -> Location.t -> bool
val split_compiler_error : Location.Error.t -> Location.t * string
val explode_str : string -> char list
module Clflags : module type of Ocaml_common.Clflags
val parse_lid : string -> Longident.t
================================================
FILE: src/reason-parser/reason_toolchain.ml
================================================
(***********************************************************************)
(* *)
(* Reason *)
(* *)
(***********************************************************************)
(*
* Copyright (c) 2015-present, Facebook, Inc.
*
* This source code is licensed under the MIT license found in the
* LICENSE file in the root directory of this source tree.
*)
(* Entry points in the parser *)
(*
* Provides a simple interface to the most common parsing entrypoints required
* by editor/IDE toolchains, preprocessors, and pretty printers.
*
* The form of this entrypoint includes more than what the standard OCaml
* toolchain (oprof/ocamldoc) expects, but is still compatible.
*
* [implementation_with_comments] and [interface_with_comments] includes
* additional information (about comments) suitable for building pretty
* printers, editor, IDE and VCS integration.
*
* The comments include the full text of the comment (typically in between the
* "(*" and the "*)", as well as location information for that comment.
*
* WARNING: The "end" location is one greater than the actual final position!
* (for both [associatedTextLoc] and [commentLoc]).
*
* Currently, the location information for comments is of the form:
*
* (associatedTextLoc)
*
* But we should quickly change it to be of the form:
*
* (associatedTextLoc, commentLoc)
*
* Where the [commentLoc] is the actual original location of the comment,
* and the [associatedTextLoc] records the location in the file that the
* comment is attached to. If [associatedTextLoc] and [commentLoc] are the
* same, then the comment is "free floating" in that it only attaches to itself.
* The [Reason] pretty printer will try its best to interleave those comments
* in the containing list etc. But if [associatedTextLoc] expands beyond
* the [commentLoc] it means the comment and the AST that is captured by
* the [associatedTextLoc] are related - where "related" is something
* this [reason_toolchain] decides (but in short it handles "end of line
* comments"). Various pretty printers can decide how to preserve this
* relatedness. Ideally, it would preserve end of line comments, but in the
* short term, it might merely use that relatedness to correctly attach
* end of line comments to the "top" of the AST node.
*
* let lst = [
*
* ]; (* Comment *)
* ----commentLoc-----
* ---associatedTextLoc----
*
*
* Ideally that would be formatted as:
*
* let lst = [
*
* ]; (* Comment *)
*
* Or:
*
* let lst = [ ]; (* Comment *)
*
*
* But a shorter term solution would use that [associatedTextLoc] to at least
* correctly attach the comment to the correct node, even if not "end of line".
*
* (* Comment *)
* let lst = [ ];
*)
open Ppxlib
let setup_lexbuf ~use_stdin filename =
(* Use custom method of lexing from the channel to keep track of the input so
that we can reformat tokens in the toolchain*)
let lexbuf =
match use_stdin with
| true -> Lexing.from_channel stdin
| false ->
let file_chan = open_in filename in
seek_in file_chan 0;
Lexing.from_channel file_chan
in
Location.init lexbuf filename;
lexbuf
let rec left_expand_comment should_scan_prev_line source loc_start =
if loc_start = 0
then String.unsafe_get source 0, true, 0
else
let c = String.unsafe_get source (loc_start - 1) in
match c with
| '\t' | ' ' ->
left_expand_comment should_scan_prev_line source (loc_start - 1)
| '\n' when should_scan_prev_line ->
left_expand_comment should_scan_prev_line source (loc_start - 1)
| '\n' -> c, true, loc_start
| _ -> c, false, loc_start
let rec right_expand_comment should_scan_next_line source loc_start =
if loc_start = String.length source
then
( String.unsafe_get source (String.length source - 1)
, true
, String.length source )
else
let c = String.unsafe_get source loc_start in
match c with
| '\t' | ' ' ->
right_expand_comment should_scan_next_line source (loc_start + 1)
| '\n' when should_scan_next_line ->
right_expand_comment should_scan_next_line source (loc_start + 1)
| '\n' -> c, true, loc_start
| _ -> c, false, loc_start
module Create_parse_entrypoint
(Toolchain_impl : Reason_toolchain_conf.Toolchain_spec) :
Reason_toolchain_conf.Toolchain = struct
let buffer_add_lexbuf buf skip lexbuf =
let bytes = lexbuf.Lexing.lex_buffer in
let start = lexbuf.Lexing.lex_start_pos + skip in
let stop = lexbuf.Lexing.lex_buffer_len in
Buffer.add_subbytes buf bytes start (stop - start)
let refill_buff buf refill lb =
let skip = lb.Lexing.lex_buffer_len - lb.Lexing.lex_start_pos in
let result = refill lb in
buffer_add_lexbuf buf skip lb;
result
(* replaces Lexing.from_channel so we can keep track of the input for comment
modification *)
let keep_from_lexbuf buffer lexbuf =
buffer_add_lexbuf buffer 0 lexbuf;
let refill_buff = refill_buff buffer lexbuf.Lexing.refill_buff in
{ lexbuf with refill_buff }
let extensions_of_errors errors =
ignore (Format.flush_str_formatter () : string);
let error_extension (err, loc) =
Reason_errors.report_error Format.str_formatter ~loc err;
let msg = Format.flush_str_formatter () in
let due_to_recovery =
match err with
| Reason_errors.Parsing_error _ -> true
| Reason_errors.Lexing_error _ -> false
| Reason_errors.Ast_error _ -> false
in
if due_to_recovery
then Reason_errors.error_extension_node_from_recovery loc msg
else Reason_errors.error_extension_node loc msg
in
List.map ~f:error_extension errors
let wrap_with_comments parsing_fun attach_fun lexbuf =
let input_copy = Buffer.create 0 in
let lexbuf = keep_from_lexbuf input_copy lexbuf in
Toolchain_impl.safeguard_parsing lexbuf (fun () ->
let lexer =
let insert_completion_ident =
!Reason_toolchain_conf.insert_completion_ident
in
Toolchain_impl.Lexer.init ?insert_completion_ident lexbuf
in
let ast, invalid_docstrings =
let result =
if !Reason_config.recoverable
then
Reason_errors.recover_non_fatal_errors (fun () -> parsing_fun lexer)
else Ok (parsing_fun lexer), []
in
match result with
| Ok x, [] -> x
| Ok (x, ds), errors -> attach_fun x (extensions_of_errors errors), ds
| Error exn, _ -> raise exn
in
let unmodified_comments =
Toolchain_impl.Lexer.get_comments lexer invalid_docstrings
in
let contents = Buffer.contents input_copy in
Buffer.reset input_copy;
if contents = ""
then
let _ = Parsing.clear_parser () in
let make_regular (text, location) =
Reason_comment.make ~location Reason_comment.Regular text
in
ast, List.map ~f:make_regular unmodified_comments
else
let rec classifyAndNormalizeComments unmodified_comments =
match unmodified_comments with
| [] -> []
| hd :: tl ->
let classifiedTail = classifyAndNormalizeComments tl in
let txt, physical_loc = hd in
(* When searching for "^" regexp, returns location of newline + 1 *)
let stop_char, eol_start, virtual_start_pos =
left_expand_comment false contents physical_loc.loc_start.pos_cnum
in
if Reason_syntax_util.isLineComment txt
then
let comment =
Reason_comment.make
~location:physical_loc
(if eol_start then SingleLine else EndOfLine)
txt
in
comment :: classifiedTail
else
let one_char_before_stop_char =
if virtual_start_pos <= 1
then ' '
else String.unsafe_get contents (virtual_start_pos - 2)
in
(*
*
* The following logic are designed for cases like:
* | (* comment *)
* X => 1
* we want to extend the comment to the next line so it can be
* correctly attached to X
*
* But we don't want it to extend to next line in this case:
*
* true || (* comment *)
* false
*
*)
let should_scan_next_line =
stop_char = '|'
&& (one_char_before_stop_char = ' '
|| one_char_before_stop_char = '\n'
|| one_char_before_stop_char = '\t')
in
let _, eol_end, virtual_end_pos =
right_expand_comment
should_scan_next_line
contents
physical_loc.loc_end.pos_cnum
in
let end_pos_plus_one = physical_loc.loc_end.pos_cnum in
let comment_length =
end_pos_plus_one - physical_loc.loc_start.pos_cnum - 4
in
let original_comment_contents =
String.sub
contents
~pos:(physical_loc.loc_start.pos_cnum + 2)
~len:comment_length
in
let location =
{ physical_loc with
loc_start =
{ physical_loc.loc_start with pos_cnum = virtual_start_pos }
; loc_end =
{ physical_loc.loc_end with pos_cnum = virtual_end_pos }
}
in
let just_after loc' =
loc'.loc_start.pos_cnum == location.loc_end.pos_cnum - 1
&& loc'.loc_start.pos_lnum == location.loc_end.pos_lnum
in
let category =
match eol_start, eol_end, classifiedTail with
| true, true, _ -> Reason_comment.SingleLine
| false, true, _ -> Reason_comment.EndOfLine
| false, false, comment :: _
(* End of line comment is one that has nothing but newlines or
* other comments its right, and has some AST to the left of it.
* For example, there are two end of line comments in:
*
* | Y(int, int); /* eol1 */ /* eol2 */
*)
when Reason_comment.category comment
= Reason_comment.EndOfLine
&& just_after (Reason_comment.location comment) ->
Reason_comment.EndOfLine
| _ -> Reason_comment.Regular
in
let comment =
Reason_comment.make ~location category original_comment_contents
in
comment :: classifiedTail
in
let modified_and_comment_with_category =
classifyAndNormalizeComments unmodified_comments
in
let _ = Parsing.clear_parser () in
ast, modified_and_comment_with_category)
let default_error lexbuf err =
if !Reason_config.recoverable
then
let loc, msg =
match err with
| Location.Error err -> Reason_syntax_util.split_compiler_error err
| Reason_errors.Reason_error (e, loc) ->
Reason_errors.report_error Format.str_formatter ~loc e;
loc, Format.flush_str_formatter ()
| exn ->
Location.of_lexbuf lexbuf, "default_error: " ^ Printexc.to_string exn
in
loc, Reason_errors.error_extension_node loc msg
else raise err
let ignore_attach_errors x _extensions = (* FIXME: attach errors in AST *) x
(*
* The canonical interface/implementations (with comments) are used with
* recovering mode for IDE integration. The parser itself likely
* implements its own recovery, but we need to recover in the event
* that the file couldn't even lex.
* Note, the location reported here is broken for some lexing errors
* (nested comments or unbalanced strings in comments) but at least we don't
* crash the process. TODO: Report more accurate location in those cases.
*)
let implementation_with_comments lexbuf =
let attach impl extensions =
impl @ List.map ~f:Ast_helper.Str.extension extensions
in
try wrap_with_comments Toolchain_impl.implementation attach lexbuf with
| err ->
let loc, error = default_error lexbuf err in
[ Ast_helper.Str.mk ~loc (Parsetree.Pstr_extension (error, [])) ], []
let core_type_with_comments lexbuf =
try
wrap_with_comments Toolchain_impl.core_type ignore_attach_errors lexbuf
with
| err ->
let loc, error = default_error lexbuf err in
Ast_helper.Typ.mk ~loc (Parsetree.Ptyp_extension error), []
let interface_with_comments lexbuf =
let attach impl extensions =
impl @ List.map ~f:Ast_helper.Sig.extension extensions
in
try wrap_with_comments Toolchain_impl.interface attach lexbuf with
| err ->
let loc, error = default_error lexbuf err in
[ Ast_helper.Sig.mk ~loc (Parsetree.Psig_extension (error, [])) ], []
let toplevel_phrase_with_comments lexbuf =
wrap_with_comments
Toolchain_impl.toplevel_phrase
ignore_attach_errors
lexbuf
let use_file_with_comments lexbuf =
wrap_with_comments Toolchain_impl.use_file ignore_attach_errors lexbuf
(** [ast_only] wraps a function to return only the ast component *)
let ast_only f lexbuf = lexbuf |> f |> fst
let implementation = ast_only implementation_with_comments
let core_type = ast_only core_type_with_comments
let interface = ast_only interface_with_comments
let toplevel_phrase = ast_only toplevel_phrase_with_comments
let use_file = ast_only use_file_with_comments
(* Printing *)
let print_interface_with_comments formatter interface =
Toolchain_impl.format_interface_with_comments interface formatter
let print_implementation_with_comments formatter implementation =
Toolchain_impl.format_implementation_with_comments implementation formatter
end
module ML = Create_parse_entrypoint (Reason_toolchain_ocaml)
module RE = Create_parse_entrypoint (Reason_toolchain_reason)
module From_current = Reason_toolchain_conf.From_current
module To_current = Reason_toolchain_conf.To_current
================================================
FILE: src/reason-parser/reason_toolchain.mli
================================================
(***********************************************************************)
(* *)
(* Reason *)
(* *)
(***********************************************************************)
(*
* Copyright (c) 2015-present, Facebook, Inc.
*
* This source code is licensed under the MIT license found in the
* LICENSE file in the root directory of this source tree.
*)
(* open Ppxlib *)
module ML : Reason_toolchain_conf.Toolchain
module RE : Reason_toolchain_conf.Toolchain
module From_current = Reason_toolchain_conf.From_current
module To_current = Reason_toolchain_conf.To_current
val setup_lexbuf : use_stdin:bool -> string -> Lexing.lexbuf
================================================
FILE: src/reason-parser/reason_toolchain_conf.ml
================================================
open Ppxlib
module From_current = struct
include Selected_ast.Of_ocaml
include Reason_omp.Convert (Reason_omp.OCaml_current) (Reason_omp.OCaml_414)
end
module To_current = struct
include Selected_ast.To_ocaml
include Reason_omp.Convert (Reason_omp.OCaml_414) (Reason_omp.OCaml_current)
end
module type Toolchain = sig
(* Parsing *)
val core_type_with_comments :
Lexing.lexbuf
-> Parsetree.core_type * Reason_comment.t list
val implementation_with_comments :
Lexing.lexbuf
-> Parsetree.structure * Reason_comment.t list
val interface_with_comments :
Lexing.lexbuf
-> Parsetree.signature * Reason_comment.t list
val core_type : Lexing.lexbuf -> Parsetree.core_type
val implementation : Lexing.lexbuf -> Parsetree.structure
val interface : Lexing.lexbuf -> Parsetree.signature
val toplevel_phrase : Lexing.lexbuf -> Parsetree.toplevel_phrase
val use_file : Lexing.lexbuf -> Parsetree.toplevel_phrase list
(* Printing *)
val print_interface_with_comments :
Format.formatter
-> Parsetree.signature * Reason_comment.t list
-> unit
val print_implementation_with_comments :
Format.formatter
-> Parsetree.structure * Reason_comment.t list
-> unit
end
module type Toolchain_spec = sig
val safeguard_parsing :
Lexing.lexbuf
-> (unit -> 'a * Reason_comment.t list)
-> 'a * Reason_comment.t list
type token
type invalid_docstrings
module Lexer : sig
type t
val init : ?insert_completion_ident:Lexing.position -> Lexing.lexbuf -> t
val get_comments : t -> invalid_docstrings -> (string * Location.t) list
end
val core_type : Lexer.t -> Parsetree.core_type * invalid_docstrings
val implementation : Lexer.t -> Parsetree.structure * invalid_docstrings
val interface : Lexer.t -> Parsetree.signature * invalid_docstrings
val toplevel_phrase :
Lexer.t
-> Parsetree.toplevel_phrase * invalid_docstrings
val use_file : Lexer.t -> Parsetree.toplevel_phrase list * invalid_docstrings
val format_interface_with_comments :
Parsetree.signature * Reason_comment.t list
-> Format.formatter
-> unit
val format_implementation_with_comments :
Parsetree.structure * Reason_comment.t list
-> Format.formatter
-> unit
end
let insert_completion_ident : Lexing.position option ref = ref None
================================================
FILE: src/reason-parser/reason_toolchain_conf.mli
================================================
open Ppxlib
module type Toolchain = sig
(* Parsing *)
val core_type_with_comments :
Lexing.lexbuf
-> Parsetree.core_type * Reason_comment.t list
val implementation_with_comments :
Lexing.lexbuf
-> Parsetree.structure * Reason_comment.t list
val interface_with_comments :
Lexing.lexbuf
-> Parsetree.signature * Reason_comment.t list
val core_type : Lexing.lexbuf -> Parsetree.core_type
val implementation : Lexing.lexbuf -> Parsetree.structure
val interface : Lexing.lexbuf -> Parsetree.signature
val toplevel_phrase : Lexing.lexbuf -> Parsetree.toplevel_phrase
val use_file : Lexing.lexbuf -> Parsetree.toplevel_phrase list
(* Printing *)
val print_interface_with_comments :
Format.formatter
-> Parsetree.signature * Reason_comment.t list
-> unit
val print_implementation_with_comments :
Format.formatter
-> Parsetree.structure * Reason_comment.t list
-> unit
end
module type Toolchain_spec = sig
val safeguard_parsing :
Lexing.lexbuf
-> (unit -> 'a * Reason_comment.t list)
-> 'a * Reason_comment.t list
type token
type invalid_docstrings
module Lexer : sig
type t
val init : ?insert_completion_ident:Lexing.position -> Lexing.lexbuf -> t
val get_comments : t -> invalid_docstrings -> (string * Location.t) list
end
val core_type : Lexer.t -> Parsetree.core_type * invalid_docstrings
val implementation : Lexer.t -> Parsetree.structure * invalid_docstrings
val interface : Lexer.t -> Parsetree.signature * invalid_docstrings
val toplevel_phrase :
Lexer.t
-> Parsetree.toplevel_phrase * invalid_docstrings
val use_file : Lexer.t -> Parsetree.toplevel_phrase list * invalid_docstrings
val format_interface_with_comments :
Parsetree.signature * Reason_comment.t list
-> Format.formatter
-> unit
val format_implementation_with_comments :
Parsetree.structure * Reason_comment.t list
-> Format.formatter
-> unit
end
val insert_completion_ident : Lexing.position option ref
module From_current : sig
val copy_structure :
Ppxlib_ast.Compiler_version.Ast.Parsetree.structure
-> Ppxlib.Parsetree.structure
val copy_signature :
Ppxlib_ast.Compiler_version.Ast.Parsetree.signature
-> Ppxlib.Parsetree.signature
val copy_expression :
Ppxlib_ast.Compiler_version.Ast.Parsetree.expression
-> Ppxlib.Parsetree.expression
val copy_core_type :
Ppxlib_ast.Compiler_version.Ast.Parsetree.core_type
-> Ppxlib.Parsetree.core_type
val copy_pattern :
Ppxlib_ast.Compiler_version.Ast.Parsetree.pattern
-> Ppxlib.Parsetree.pattern
val copy_case :
Ppxlib_ast.Compiler_version.Ast.Parsetree.case
-> Ppxlib.Parsetree.case
val copy_toplevel_phrase :
Ppxlib_ast.Compiler_version.Ast.Parsetree.toplevel_phrase
-> Ppxlib.Parsetree.toplevel_phrase
val copy_out_value :
Reason_omp.OCaml_current.Ast.Outcometree.out_value
-> Reason_omp.OCaml_414.Ast.Outcometree.out_value
val copy_out_type :
Reason_omp.OCaml_current.Ast.Outcometree.out_type
-> Reason_omp.OCaml_414.Ast.Outcometree.out_type
val copy_out_class_type :
Reason_omp.OCaml_current.Ast.Outcometree.out_class_type
-> Reason_omp.OCaml_414.Ast.Outcometree.out_class_type
val copy_out_module_type :
Reason_omp.OCaml_current.Ast.Outcometree.out_module_type
-> Reason_omp.OCaml_414.Ast.Outcometree.out_module_type
val copy_out_sig_item :
Reason_omp.OCaml_current.Ast.Outcometree.out_sig_item
-> Reason_omp.OCaml_414.Ast.Outcometree.out_sig_item
val copy_out_type_extension :
Reason_omp.OCaml_current.Ast.Outcometree.out_type_extension
-> Reason_omp.OCaml_414.Ast.Outcometree.out_type_extension
val copy_out_phrase :
Reason_omp.OCaml_current.Ast.Outcometree.out_phrase
-> Reason_omp.OCaml_414.Ast.Outcometree.out_phrase
end
module To_current : sig
val copy_structure :
Ppxlib.Parsetree.structure
-> Ppxlib_ast.Compiler_version.Ast.Parsetree.structure
val copy_signature :
Ppxlib.Parsetree.signature
-> Ppxlib_ast.Compiler_version.Ast.Parsetree.signature
val copy_core_type :
Ppxlib.Parsetree.core_type
-> Ppxlib_ast.Compiler_version.Ast.Parsetree.core_type
val copy_toplevel_phrase :
Ppxlib.Parsetree.toplevel_phrase
-> Ppxlib_ast.Compiler_version.Ast.Parsetree.toplevel_phrase
val copy_out_value :
Reason_omp.OCaml_414.Ast.Outcometree.out_value
-> Reason_omp.OCaml_current.Ast.Outcometree.out_value
val copy_out_type :
Reason_omp.OCaml_414.Ast.Outcometree.out_type
-> Reason_omp.OCaml_current.Ast.Outcometree.out_type
val copy_out_class_type :
Reason_omp.OCaml_414.Ast.Outcometree.out_class_type
-> Reason_omp.OCaml_current.Ast.Outcometree.out_class_type
val copy_out_module_type :
Reason_omp.OCaml_414.Ast.Outcometree.out_module_type
-> Reason_omp.OCaml_current.Ast.Outcometree.out_module_type
val copy_out_sig_item :
Reason_omp.OCaml_414.Ast.Outcometree.out_sig_item
-> Reason_omp.OCaml_current.Ast.Outcometree.out_sig_item
val copy_out_type_extension :
Reason_omp.OCaml_414.Ast.Outcometree.out_type_extension
-> Reason_omp.OCaml_current.Ast.Outcometree.out_type_extension
val copy_out_phrase :
Reason_omp.OCaml_414.Ast.Outcometree.out_phrase
-> Reason_omp.OCaml_current.Ast.Outcometree.out_phrase
end
================================================
FILE: src/reason-parser/reason_toolchain_ocaml.ml
================================================
open Ppxlib
(* The OCaml parser keep doc strings in the comment list. To avoid duplicating
comments, we need to filter comments that appear as doc strings is the AST
out of the comment list. *)
let doc_comments_filter () =
let seen = Hashtbl.create 7 in
let mapper =
object
inherit Ast_traverse.map as super
method! attribute attr =
match attr with
| { attr_name = { Location.txt = "ocaml.doc" | "ocaml.text"; _ }
; attr_payload =
PStr
[ { pstr_desc =
Pstr_eval
( { pexp_desc =
Pexp_constant (Pconst_string (_text, _loc, None))
; _
}
, _ )
; pstr_loc = loc
}
]
; _
} as attribute ->
(* Workaround: OCaml 4.02.3 kept an initial '*' in docstrings.
* For other versions, we have to put the '*' back. *)
Hashtbl.add seen loc ();
super#attribute attribute
| attribute -> super#attribute attribute
end
in
let filter (_text, loc) = not (Hashtbl.mem seen loc) in
mapper, filter
module Lexer_impl = struct
type t = Lexing.lexbuf
let init ?insert_completion_ident:_ lexbuf =
Lexer.init ();
lexbuf
let filtered_comments = ref []
let filter_comments filter =
filtered_comments := List.filter ~f:filter (Lexer.comments ())
let get_comments _lexbuf _docstrings = !filtered_comments
end
module OCaml_parser = Ocaml_common.Parser
type token = OCaml_parser.token
type invalid_docstrings = unit
(* OCaml parser parses into compiler-libs version of Ast. Parsetrees are
converted to Reason version on the fly. *)
let parse_and_filter_doc_comments iter fn lexbuf =
let it, filter = doc_comments_filter () in
let result = fn lexbuf in
ignore (iter it result);
Lexer_impl.filter_comments filter;
result, ()
let implementation lexbuf =
parse_and_filter_doc_comments
(fun it stru -> it#structure stru)
(fun lexbuf ->
Reason_toolchain_conf.From_current.copy_structure
(OCaml_parser.implementation Lexer.token lexbuf))
lexbuf
let core_type lexbuf =
parse_and_filter_doc_comments
(fun it ty -> it#core_type ty)
(fun lexbuf ->
Reason_toolchain_conf.From_current.copy_core_type
(OCaml_parser.parse_core_type Lexer.token lexbuf))
lexbuf
let interface lexbuf =
parse_and_filter_doc_comments
(fun it sig_ -> it#signature sig_)
(fun lexbuf ->
Reason_toolchain_conf.From_current.copy_signature
(OCaml_parser.interface Lexer.token lexbuf))
lexbuf
let filter_toplevel_phrase it = function
| Parsetree.Ptop_def str -> ignore (it#structure str)
| Parsetree.Ptop_dir _ -> ()
let toplevel_phrase lexbuf =
parse_and_filter_doc_comments
filter_toplevel_phrase
(fun lexbuf ->
Reason_toolchain_conf.From_current.copy_toplevel_phrase
(OCaml_parser.toplevel_phrase Lexer.token lexbuf))
lexbuf
let use_file lexbuf =
parse_and_filter_doc_comments
(fun it result -> List.map ~f:(filter_toplevel_phrase it) result)
(fun lexbuf ->
List.map
~f:Reason_toolchain_conf.From_current.copy_toplevel_phrase
(OCaml_parser.use_file Lexer.token lexbuf))
lexbuf
(* Skip tokens to the end of the phrase *)
(* TODO: consolidate these copy-paste skip/trys into something that works for
* every syntax (also see [Reason_syntax_util]). *)
let rec skip_phrase lexbuf =
try
match Lexer.token lexbuf with
| OCaml_parser.SEMISEMI | OCaml_parser.EOF -> ()
| _ -> skip_phrase lexbuf
with
| Lexer.Error (Lexer.Unterminated_comment _, _)
| Lexer.Error (Lexer.Unterminated_string, _)
| Lexer.Error (Lexer.Unterminated_string_in_comment _, _)
| Lexer.Error (Lexer.Illegal_character _, _) ->
skip_phrase lexbuf
let maybe_skip_phrase lexbuf =
if
Parsing.is_current_lookahead OCaml_parser.SEMISEMI
|| Parsing.is_current_lookahead OCaml_parser.EOF
then ()
else skip_phrase lexbuf
module Location = Ocaml_common.Location
let safeguard_parsing lexbuf fn =
try fn () with
| Lexer.Error (Lexer.Illegal_character _, _) as err
when !Location.input_name = "//toplevel//" ->
skip_phrase lexbuf;
raise err
| Syntaxerr.Error _ as err when !Location.input_name = "//toplevel//" ->
maybe_skip_phrase lexbuf;
raise err
(* Escape error is raised as a general catchall when a syntax_error() is
thrown in the parser. *)
| Parsing.Parse_error | Syntaxerr.Escape_error ->
let loc = Location.curr lexbuf in
if !Location.input_name = "//toplevel//" then maybe_skip_phrase lexbuf;
raise (Syntaxerr.Error (Syntaxerr.Other loc))
(* Unfortunately we drop the comments because there doesn't exist an ML
* printer that formats comments *and* line wrapping! (yet) *)
let format_interface_with_comments (signature, _) formatter =
Ocaml_common.Pprintast.signature
formatter
(Reason_toolchain_conf.To_current.copy_signature signature)
let format_implementation_with_comments (structure, _) formatter =
let structure =
structure
|> Reason_syntax_util.(apply_mapper_to_structure backport_letopt_mapper)
|> Reason_syntax_util.(
apply_mapper_to_structure remove_stylistic_attrs_mapper)
in
Ocaml_common.Pprintast.structure
formatter
(Reason_toolchain_conf.To_current.copy_structure structure)
module Lexer = Lexer_impl
================================================
FILE: src/reason-parser/reason_toolchain_ocaml.mli
================================================
include Reason_toolchain_conf.Toolchain_spec
================================================
FILE: src/reason-parser/reason_toolchain_reason.ml
================================================
module P = Reason_recover_parser
module Lexer = Reason_lexer
(* From Reason source text to OCaml AST
*
* 1. Make a lexbuf from source text
* 2. Reason_lexer:
* a. Using OCamllex:
* extract one token from stream of characters
* b. post-process token:
* - store comments separately
* - insert ES6_FUN token
* - insert completion identifier
* 3. Reason_parser, using Menhir:
* A parser with explicit continuations, which take a new token and return:
* - an AST when parse succeeded
* - a new continuation if more tokens are needed
* - nothing, if the parser got stuck (token is invalid in current state)
* 4. Reason_toolchain connect lexer and parser:
*)
type token = Reason_parser.token
type invalid_docstrings = Reason_lexer.invalid_docstrings
let rec loop lexer parser =
let token = Lexer.token lexer in
match P.step parser token with
| P.Intermediate parser' -> loop lexer parser'
| P.Error ->
(* Impossible to reach this case? *)
let _, loc_start, loc_end = token in
let loc = { Location.loc_start; loc_end; loc_ghost = false } in
Reason_errors.raise_fatal_error (Parsing_error "Syntax error") loc
| P.Success (x, docstrings) -> x, docstrings
let initial_run entry_point lexer =
loop lexer (P.initial entry_point (Lexer.lexbuf lexer).Lexing.lex_curr_p)
let implementation lexer =
initial_run Reason_parser.Incremental.implementation lexer
let interface lexer = initial_run Reason_parser.Incremental.interface lexer
let core_type lexer =
initial_run Reason_parser.Incremental.parse_core_type lexer
let toplevel_phrase lexer =
initial_run Reason_parser.Incremental.toplevel_phrase lexer
let use_file lexer = initial_run Reason_parser.Incremental.use_file lexer
(* Skip tokens to the end of the phrase *)
let rec skip_phrase lexer =
try
match Lexer.token lexer with
| (Reason_parser.SEMI | Reason_parser.EOF), _, _ -> ()
| _ -> skip_phrase lexer
with
| Reason_errors.Reason_error
( Lexing_error
( Unterminated_comment _ | Unterminated_string
| Unterminated_string_in_comment _ | Illegal_character _ )
, _ ) ->
skip_phrase lexer
let safeguard_parsing lexbuf fn =
try fn () with
| Reason_errors.Reason_error _ as err
when !Location.input_name = "//toplevel//" ->
skip_phrase (Lexer.init lexbuf);
raise err
| Location.Error _ as x ->
let loc = Location.curr lexbuf in
if !Location.input_name = "//toplevel//"
then
let _ = skip_phrase (Lexer.init lexbuf) in
raise (Syntaxerr.Error (Syntaxerr.Other loc))
else raise x
let format_interface_with_comments (signature, comments) formatter =
let reason_formatter = Reason_pprint_ast.createFormatter () in
reason_formatter#signature comments formatter signature
let format_implementation_with_comments (implementation, comments) formatter =
let reason_formatter = Reason_pprint_ast.createFormatter () in
reason_formatter#structure comments formatter implementation
================================================
FILE: src/reason-parser/reason_toolchain_reason.mli
================================================
include Reason_toolchain_conf.Toolchain_spec
================================================
FILE: src/reason-parser/vendor/easy_format/VERSION
================================================
1.2.0
================================================
FILE: src/reason-parser/vendor/easy_format/dune
================================================
(library
(name reason_easy_format)
(public_name reason.easy_format)
(preprocess
(action
(run %{bin:cppo} -V OCAML:%{ocaml_version} %{input-file})))
(flags
(:standard -w -9-27-32-50)))
================================================
FILE: src/reason-parser/vendor/easy_format/reason_easy_format.ml
================================================
open Format
(** Shadow map and split with tailrecursive variants. *)
module List = struct
include List
(** Tail recursive of map *)
let map f l = List.rev_map f l |> List.rev
(** Tail recursive version of split *)
let rev_split l =
let rec inner xs ys = function
| (x, y) :: xys ->
inner (x::xs) (y::ys) xys
| [] -> (xs, ys)
in
inner [] [] l
let split l = rev_split (List.rev l)
end
type wrap = [
| `Wrap_atoms
| `Always_wrap
| `Never_wrap
| `Force_breaks
| `Force_breaks_rec
| `No_breaks
]
type label_break = [
| `Auto
| `Always
| `Always_rec
| `Never
]
type style_name = string
type style = {
tag_open : string;
tag_close : string
}
type atom_param = {
atom_style : style_name option;
}
let atom = {
atom_style = None
}
type list_param = {
space_after_opening : bool;
space_after_separator : bool;
space_before_separator : bool;
separators_stick_left : bool;
space_before_closing : bool;
stick_to_label : bool;
align_closing : bool;
wrap_body : wrap;
indent_body : int;
list_style : style_name option;
opening_style : style_name option;
body_style : style_name option;
separator_style : style_name option;
closing_style : style_name option;
}
let list = {
space_after_opening = true;
space_after_separator = true;
space_before_separator = false;
separators_stick_left = true;
space_before_closing = true;
stick_to_label = true;
align_closing = true;
wrap_body = `Wrap_atoms;
indent_body = 2;
list_style = None;
opening_style = None;
body_style = None;
separator_style = None;
closing_style = None;
}
type label_param = {
label_break: label_break;
space_after_label : bool;
indent_after_label : int;
label_style : style_name option;
}
let label = {
label_break = `Auto;
space_after_label = true;
indent_after_label = 2;
label_style = None;
}
type t =
Atom of string * atom_param
| List of (string * string * string * list_param) * t list
| Label of (t * label_param) * t
| Custom of (formatter -> unit)
type escape =
[ `None
| `Escape of
((string -> int -> int -> unit) -> string -> int -> int -> unit)
| `Escape_string of (string -> string) ]
type styles = (style_name * style) list
(*
Transform a tree starting from the leaves, propagating and merging
accumulators until reaching the root.
*)
let propagate_from_leaf_to_root
~init_acc (* create initial accumulator for a leaf *)
~merge_acc (* merge two accumulators coming from child nodes *)
~map_node (* (node, acc) -> (node, acc) *)
x =
let rec aux x =
match x with
| Atom _ ->
let acc = init_acc x in
map_node x acc
| List (param, children) ->
let new_children, accs = List.rev_split (List.rev_map aux children) in
let acc = List.fold_left merge_acc (init_acc x) accs in
map_node (List (param, new_children)) acc
| Label ((x1, param), x2) ->
let acc0 = init_acc x in
let new_x1, acc1 = aux x1 in
let new_x2, acc2 = aux x2 in
let acc = merge_acc (merge_acc acc0 acc1) acc2 in
map_node (Label ((new_x1, param), new_x2)) acc
| Custom _ ->
let acc = init_acc x in
map_node x acc
in
aux x
(*
Convert wrappable lists into vertical lists if any of their descendants
has the attribute wrap_body = `Force_breaks_rec.
*)
let propagate_forced_breaks x =
(* acc = whether to force breaks in wrappable lists or labels *)
let init_acc = function
| List ((_, _, _, { wrap_body = `Force_breaks_rec }), _)
| Label ((_, { label_break = `Always_rec }), _) -> true
| Atom _
| Label _
| Custom _
| List _ -> false
in
let merge_acc force_breaks1 force_breaks2 =
force_breaks1 || force_breaks2
in
let map_node x force_breaks =
match x with
| List ((_, _, _, { wrap_body = `Force_breaks_rec }), _) -> x, true
| List ((_, _, _, { wrap_body = `Force_breaks }), _) -> x, force_breaks
| List ((op, sep, cl, ({ wrap_body = (`Wrap_atoms
| `Never_wrap
| `Always_wrap) } as p)),
children) ->
if force_breaks then
let p = { p with wrap_body = `Force_breaks } in
List ((op, sep, cl, p), children), true
else
x, false
| Label ((a, ({ label_break = `Auto } as lp)), b) ->
if force_breaks then
let lp = { lp with label_break = `Always } in
Label ((a, lp), b), true
else
x, false
| List ((_, _, _, { wrap_body = `No_breaks }), _)
| Label ((_, { label_break = (`Always | `Always_rec | `Never) }), _)
| Atom _
| Custom _ -> x, force_breaks
in
let new_x, forced_breaks =
propagate_from_leaf_to_root
~init_acc
~merge_acc
~map_node
x
in
new_x
module Pretty =
struct
(*
Rewrite the tree to be printed.
Currently, this is used only to handle `Force_breaks_rec.
*)
let rewrite x = propagate_forced_breaks x
(*
Relies on the fact that mark_open_tag and mark_close_tag
are called exactly once before calling pp_output_string once.
It's a reasonable assumption although not guaranteed by the
documentation of the Format module.
*)
let set_escape fmt escape =
let print0, flush0 = pp_get_formatter_output_functions fmt () in
let tagf0 =
#if OCAML_VERSION >= (5, 0, 0)
pp_get_formatter_stag_functions
#else
(pp_get_formatter_tag_functions [@warning "-3"])
#endif
fmt () in
let is_tag = ref false in
let mot tag =
is_tag := true;
#if OCAML_VERSION >= (5, 0, 0)
tagf0.mark_open_stag tag
#else
tagf0.mark_open_tag tag
#endif
in
let mct tag =
is_tag := true;
#if OCAML_VERSION >= (5, 0, 0)
tagf0.mark_close_stag tag
#else
tagf0.mark_close_tag tag
#endif
in
let print s p n =
if !is_tag then
(print0 s p n;
is_tag := false)
else
escape print0 s p n
in
let tagf = {
tagf0 with
#if OCAML_VERSION >= (5, 0, 0)
mark_open_stag = mot;
mark_close_stag = mct
#else
mark_open_tag = mot;
mark_close_tag = mct
#endif
}
in
pp_set_formatter_output_functions fmt print flush0;
#if OCAML_VERSION >= (5, 0, 0)
pp_set_formatter_stag_functions
#else
(pp_set_formatter_tag_functions [@warning "-3"])
#endif
fmt tagf
let set_escape_string fmt esc =
let escape print s p n =
let s0 = String.sub s p n in
let s1 = esc s0 in
print s1 0 (String.length s1)
in
set_escape fmt escape
let define_styles fmt escape l =
if l <> [] then (
pp_set_tags fmt true;
let tbl1 = Hashtbl.create (2 * List.length l) in
let tbl2 = Hashtbl.create (2 * List.length l) in
List.iter (
fun (style_name, style) ->
Hashtbl.add tbl1 style_name style.tag_open;
Hashtbl.add tbl2 style_name style.tag_close
) l;
#if OCAML_VERSION >= (5, 0, 0)
let mark_open_tag = function
| Format.String_tag style_name ->
(try Hashtbl.find tbl1 style_name
with Not_found -> "")
| _ -> ""
in
let mark_close_tag = function
| Format.String_tag style_name ->
(try Hashtbl.find tbl2 style_name
with Not_found -> "")
| _ ->
""
#else
let mark_open_tag style_name =
try Hashtbl.find tbl1 style_name
with Not_found -> ""
in
let mark_close_tag style_name =
try Hashtbl.find tbl2 style_name
with Not_found -> ""
#endif
in
let tagf = {
(
#if OCAML_VERSION >= (5, 0, 0)
pp_get_formatter_stag_functions
#else
(pp_get_formatter_tag_functions [@warning "-3"])
#endif
fmt ()
) with
#if OCAML_VERSION >= (5, 0, 0)
mark_open_stag = mark_open_tag;
mark_close_stag = mark_close_tag;
#else
mark_open_tag = mark_open_tag;
mark_close_tag = mark_close_tag;
#endif
}
in
#if OCAML_VERSION >= (5, 0, 0)
pp_set_formatter_stag_functions
#else
(pp_set_formatter_tag_functions [@warning "-3"])
#endif
fmt tagf
);
(match escape with
`None -> ()
| `Escape esc -> set_escape fmt esc
| `Escape_string esc -> set_escape_string fmt esc)
let pp_open_xbox fmt p indent =
match p.wrap_body with
`Always_wrap
| `Never_wrap
| `Wrap_atoms -> pp_open_hvbox fmt indent
| `Force_breaks
| `Force_breaks_rec -> pp_open_vbox fmt indent
| `No_breaks -> pp_open_hbox fmt ()
let extra_box p l =
let wrap =
match p.wrap_body with
`Always_wrap -> true
| `Never_wrap
| `Force_breaks
| `Force_breaks_rec
| `No_breaks -> false
| `Wrap_atoms ->
List.for_all (function Atom _ -> true | _ -> false) l
in
if wrap then
((fun fmt -> pp_open_hovbox fmt 0),
(fun fmt -> pp_close_box fmt ()))
else
((fun fmt -> ()),
(fun fmt -> ()))
let pp_open_nonaligned_box fmt p indent l =
match p.wrap_body with
`Always_wrap -> pp_open_hovbox fmt indent
| `Never_wrap -> pp_open_hvbox fmt indent
| `Wrap_atoms ->
if List.for_all (function Atom _ -> true | _ -> false) l then
pp_open_hovbox fmt indent
else
pp_open_hvbox fmt indent
| `Force_breaks
| `Force_breaks_rec -> pp_open_vbox fmt indent
| `No_breaks -> pp_open_hbox fmt ()
let open_tag fmt = function
None -> ()
| Some s ->
#if OCAML_VERSION >= (5, 0, 0)
pp_open_stag
#else
(pp_open_tag [@warning "-3"])
#endif
fmt s
let close_tag fmt = function
None -> ()
| Some _ ->
#if OCAML_VERSION >= (5, 0, 0)
pp_close_stag
#else
(pp_close_tag [@warning "-3"])
#endif
fmt ()
let tag_string fmt o s =
match o with
None -> pp_print_string fmt s
| Some tag ->
#if OCAML_VERSION >= (5, 0, 0)
pp_open_stag fmt (Format.String_tag tag);
#else
(pp_open_tag [@warning "-3"]) fmt tag;
#endif
pp_print_string fmt s;
#if OCAML_VERSION >= (5, 0, 0)
pp_close_stag fmt ()
#else
(pp_close_tag [@warning "-3"]) fmt ()
#endif
let rec fprint_t fmt = function
Atom (s, p) ->
tag_string fmt p.atom_style s;
| List ((_, _, _, p) as param, l) ->
#if OCAML_VERSION >= (5, 0, 0)
open_tag fmt (match p.list_style with Some ls -> Some (Format.String_tag ls) | None -> None);
#else
open_tag fmt p.list_style;
#endif
if p.align_closing then
fprint_list fmt None param l
else
fprint_list2 fmt param l;
close_tag fmt p.list_style
| Label (label, x) -> fprint_pair fmt label x
| Custom f -> f fmt
and fprint_list_body_stick_left fmt p sep hd tl =
#if OCAML_VERSION >= (5, 0, 0)
open_tag fmt (match p.body_style with Some bs -> Some (Format.String_tag bs) | None -> None);
#else
open_tag fmt p.body_style;
#endif
fprint_t fmt hd;
List.iter (
fun x ->
if p.space_before_separator then
pp_print_string fmt " ";
tag_string fmt p.separator_style sep;
if p.space_after_separator then
pp_print_space fmt ()
else
pp_print_cut fmt ();
fprint_t fmt x
) tl;
close_tag fmt p.body_style
and fprint_list_body_stick_right fmt p sep hd tl =
#if OCAML_VERSION >= (5, 0, 0)
open_tag fmt (match p.body_style with Some bs -> Some (Format.String_tag bs) | None -> None);
#else
open_tag fmt p.body_style;
#endif
fprint_t fmt hd;
List.iter (
fun x ->
if p.space_before_separator then
pp_print_space fmt ()
else
pp_print_cut fmt ();
tag_string fmt p.separator_style sep;
if p.space_after_separator then
pp_print_string fmt " ";
fprint_t fmt x
) tl;
close_tag fmt p.body_style
and fprint_opt_label fmt = function
None -> ()
| Some (lab, lp) ->
#if OCAML_VERSION >= (5, 0, 0)
open_tag fmt (match lp.label_style with Some ls -> Some (Format.String_tag ls) | None -> None);
#else
open_tag fmt lp.label_style;
#endif
fprint_t fmt lab;
close_tag fmt lp.label_style;
if lp.space_after_label then
pp_print_string fmt " "
(* Either horizontal or vertical list *)
and fprint_list fmt label ((op, sep, cl, p) as param) = function
[] ->
fprint_opt_label fmt label;
tag_string fmt p.opening_style op;
if p.space_after_opening || p.space_before_closing then
pp_print_string fmt " ";
tag_string fmt p.closing_style cl
| hd :: tl as l ->
if tl = [] || p.separators_stick_left then
fprint_list_stick_left fmt label param hd tl l
else
fprint_list_stick_right fmt label param hd tl l
and fprint_list_stick_left fmt label (op, sep, cl, p) hd tl l =
let indent = p.indent_body in
pp_open_xbox fmt p indent;
fprint_opt_label fmt label;
tag_string fmt p.opening_style op;
if p.space_after_opening then
pp_print_space fmt ()
else
pp_print_cut fmt ();
let open_extra, close_extra = extra_box p l in
open_extra fmt;
fprint_list_body_stick_left fmt p sep hd tl;
close_extra fmt;
if p.space_before_closing then
pp_print_break fmt 1 (-indent)
else
pp_print_break fmt 0 (-indent);
tag_string fmt p.closing_style cl;
pp_close_box fmt ()
and fprint_list_stick_right fmt label (op, sep, cl, p) hd tl l =
let base_indent = p.indent_body in
let sep_indent =
String.length sep + (if p.space_after_separator then 1 else 0)
in
let indent = base_indent + sep_indent in
pp_open_xbox fmt p indent;
fprint_opt_label fmt label;
tag_string fmt p.opening_style op;
if p.space_after_opening then
pp_print_space fmt ()
else
pp_print_cut fmt ();
let open_extra, close_extra = extra_box p l in
open_extra fmt;
fprint_t fmt hd;
List.iter (
fun x ->
if p.space_before_separator then
pp_print_break fmt 1 (-sep_indent)
else
pp_print_break fmt 0 (-sep_indent);
tag_string fmt p.separator_style sep;
if p.space_after_separator then
pp_print_string fmt " ";
fprint_t fmt x
) tl;
close_extra fmt;
if p.space_before_closing then
pp_print_break fmt 1 (-indent)
else
pp_print_break fmt 0 (-indent);
tag_string fmt p.closing_style cl;
pp_close_box fmt ()
(* align_closing = false *)
and fprint_list2 fmt (op, sep, cl, p) = function
[] ->
tag_string fmt p.opening_style op;
if p.space_after_opening || p.space_before_closing then
pp_print_string fmt " ";
tag_string fmt p.closing_style cl
| hd :: tl as l ->
tag_string fmt p.opening_style op;
if p.space_after_opening then
pp_print_string fmt " ";
pp_open_nonaligned_box fmt p 0 l ;
if p.separators_stick_left then
fprint_list_body_stick_left fmt p sep hd tl
else
fprint_list_body_stick_right fmt p sep hd tl;
pp_close_box fmt ();
if p.space_before_closing then
pp_print_string fmt " ";
tag_string fmt p.closing_style cl
(* Printing a label:value pair.
The opening bracket stays on the same line as the key, no matter what,
and the closing bracket is either on the same line
or vertically aligned with the beginning of the key.
*)
and fprint_pair fmt ((lab, lp) as label) x =
match x with
List ((op, sep, cl, p), l) when p.stick_to_label && p.align_closing ->
fprint_list fmt (Some label) (op, sep, cl, p) l
| _ ->
let indent = lp.indent_after_label in
pp_open_hvbox fmt 0;
#if OCAML_VERSION >= (5, 0, 0)
open_tag fmt (match lp.label_style with Some ls -> Some (Format.String_tag ls) | None -> None);
#else
open_tag fmt lp.label_style;
#endif
fprint_t fmt lab;
close_tag fmt lp.label_style;
(match lp.label_break with
| `Auto ->
if lp.space_after_label then
pp_print_break fmt 1 indent
else
pp_print_break fmt 0 indent
| `Always
| `Always_rec ->
pp_force_newline fmt ();
pp_print_string fmt (String.make indent ' ')
| `Never ->
if lp.space_after_label then
pp_print_char fmt ' '
else
()
);
fprint_t fmt x;
pp_close_box fmt ()
let to_formatter fmt x =
let x = rewrite x in
fprint_t fmt x;
pp_print_flush fmt ()
let to_buffer ?(escape = `None) ?(styles = []) buf x =
let fmt = Format.formatter_of_buffer buf in
define_styles fmt escape styles;
to_formatter fmt x
let to_string ?escape ?styles x =
let buf = Buffer.create 500 in
to_buffer ?escape ?styles buf x;
Buffer.contents buf
let to_channel ?(escape = `None) ?(styles = []) oc x =
let fmt = formatter_of_out_channel oc in
define_styles fmt escape styles;
to_formatter fmt x
let to_stdout ?escape ?styles x = to_channel ?escape ?styles stdout x
let to_stderr ?escape ?styles x = to_channel ?escape ?styles stderr x
end
module Compact =
struct
open Printf
let rec fprint_t buf = function
Atom (s, _) -> Buffer.add_string buf s
| List (param, l) -> fprint_list buf param l
| Label (label, x) -> fprint_pair buf label x
| Custom f ->
(* Will most likely not be compact *)
let fmt = formatter_of_buffer buf in
f fmt;
pp_print_flush fmt ()
and fprint_list buf (op, sep, cl, _) = function
[] -> bprintf buf "%s%s" op cl
| x :: tl ->
Buffer.add_string buf op;
fprint_t buf x;
List.iter (
fun x ->
Buffer.add_string buf sep;
fprint_t buf x
) tl;
Buffer.add_string buf cl
and fprint_pair buf (label, _) x =
fprint_t buf label;
fprint_t buf x
let to_buffer buf x = fprint_t buf x
let to_string x =
let buf = Buffer.create 500 in
to_buffer buf x;
Buffer.contents buf
let to_formatter fmt x =
let s = to_string x in
Format.fprintf fmt "%s" s;
pp_print_flush fmt ()
let to_channel oc x =
let buf = Buffer.create 500 in
to_buffer buf x;
Buffer.output_buffer oc buf
let to_stdout x = to_channel stdout x
let to_stderr x = to_channel stderr x
end
(* Obsolete *)
module Param =
struct
let list_true = {
space_after_opening = true;
space_after_separator = true;
space_before_separator = true;
separators_stick_left = true;
space_before_closing = true;
stick_to_label = true;
align_closing = true;
wrap_body = `Wrap_atoms;
indent_body = 2;
list_style = None;
opening_style = None;
body_style = None;
separator_style = None;
closing_style = None;
}
let list_false = {
space_after_opening = false;
space_after_separator = false;
space_before_separator = false;
separators_stick_left = false;
space_before_closing = false;
stick_to_label = false;
align_closing = false;
wrap_body = `Wrap_atoms;
indent_body = 2;
list_style = None;
opening_style = None;
body_style = None;
separator_style = None;
closing_style = None;
}
let label_true = {
label_break = `Auto;
space_after_label = true;
indent_after_label = 2;
label_style = None;
}
let label_false = {
label_break = `Auto;
space_after_label = false;
indent_after_label = 2;
label_style = None;
}
end
================================================
FILE: src/reason-parser/vendor/easy_format/reason_easy_format.mli
================================================
(**
Easy_format: indentation made easy.
*)
(**
This module provides a functional, simplified layer over
the Format module of the standard library.
Input data must be first modelled as a tree using 3 kinds of nodes:
- atoms
- lists
- labelled nodes
Atoms represent any text that is guaranteed to be printed as-is.
Lists can model any sequence of items such as arrays of data
or lists of definitions that are labelled with something
like "int main", "let x =" or "x:".
*)
type wrap =
[ `Wrap_atoms
| `Always_wrap
| `Never_wrap
| `Force_breaks
| `Force_breaks_rec
| `No_breaks ]
(** List wrapping conditions:
- [`Wrap_atoms]: wrap if the list contains only atoms
- [`Always_wrap]: always wrap when needed
- [`Never_wrap]: never wrap,
i.e. the list is either horizontal or vertical
- [`Force_breaks]: align vertically,
i.e. always break line between list items and
align the left edge of each item.
- [`Force_breaks_rec]: same as [`Force_breaks] but turns
any wrappable ancestor node's wrap property ([`Wrap_atoms]
or [`Always_wrap]) into [`Force_breaks].
- [`No_breaks]: align horizontally,
i.e. never break line between list items
*)
type label_break = [
| `Auto
| `Always
| `Always_rec
| `Never
]
(** When to break the line after a [Label]:
- [Auto]: break after the label if there's not enough room
- [Always]: always break after the label
- [Always_rec]: always break after the label and force breaks in all parent
lists and labels, similarly to [`Force_breaks_rec] for lists.
- [Never]: never break after the label
*)
type style_name = string
type style = {
tag_open : string;
tag_close : string
}
(** Pair of opening and closing tags that are inserted around
text after pretty-printing. *)
type atom_param = {
atom_style : style_name option; (** Default: [None] *)
}
val atom : atom_param
(** List-formatting parameters.
Always derive a new set of parameters from an existing record.
See {!Easy_format.list}.
*)
type list_param = {
space_after_opening : bool; (** Whether there must be some whitespace
after the opening string.
Default: [true] *)
space_after_separator : bool; (** Whether there must be some whitespace
after the item separators.
Default: [true] *)
space_before_separator : bool; (** Whether there must be some whitespace
before the item separators.
Default: [false] *)
separators_stick_left : bool; (** Whether the separators must
stick to the item on the left.
Default: [true] *)
space_before_closing : bool; (** Whether there must be some whitespace
before the closing string.
Default: [true] *)
stick_to_label : bool; (** Whether the opening string should be fused
with the preceding label.
Default: [true] *)
align_closing : bool; (** Whether the beginning of the
closing string must be aligned
with the beginning of the opening string
(stick_to_label = false) or
with the beginning of the label if any
(stick_to_label = true).
Default: [true] *)
wrap_body : wrap; (** Defines under which conditions the list body
may be wrapped, i.e. allow several lines
and several list items per line.
Default: [`Wrap_atoms] *)
indent_body : int; (** Extra indentation of the list body.
Default: [2] *)
list_style : style_name option; (** Default: [None] *)
opening_style : style_name option; (** Default: [None] *)
body_style : style_name option; (** Default: [None] *)
separator_style : style_name option; (** Default: [None] *)
closing_style : style_name option; (** Default: [None] *)
}
val list : list_param
(** Default list-formatting parameters, using the default values
described in the type definition above.
In order to make code compatible with future versions of the library,
the record inheritance syntax should be used, e.g.
[ { list with align_closing = false } ].
If new record fields are added, the program would still compile
and work as before.
*)
(** Label-formatting parameters.
Always derive a new set of parameters from an existing record.
See {!Easy_format.label}.
*)
type label_param = {
label_break: label_break;
(** Whether to break the line after the label.
Introduced in version 1.2.0.
Default: [`Auto] *)
space_after_label : bool;
(** Whether there must be some whitespace after the label.
Default: [true] *)
indent_after_label : int;
(** Extra indentation before the item that comes after a label.
Default: [2]
*)
label_style : style_name option;
(** Default: [None] *)
}
val label : label_param
(** Default label-formatting parameters, using the default values
described in the type definition above.
In order to make code compatible with future versions of the library,
the record inheritance syntax should be used, e.g.
[ { label with indent_after_label = 0 } ].
If new record fields are added, the program would still compile
and work as before.
*)
type t =
Atom of string * atom_param (** Plain string normally
without line breaks. *)
| List of
(
string (* opening *)
* string (* separator *)
* string (* closing *)
* list_param
)
* t list
(** [List ((opening, separator, closing, param), nodes)] *)
| Label of (t * label_param) * t
(** [Label ((label, param), node)]: labelled node. *)
| Custom of (Format.formatter -> unit)
(** User-defined printing function that allows to use the
Format module directly if necessary. It is responsible
for leaving the formatter in a clean state. *)
(** The type of the tree to be pretty-printed. Each node contains
its own formatting parameters.
Detail of a list node
[List ((opening, separator, closing, param), nodes)]:
- [opening]: opening string such as ["\{"] ["\["] ["("] ["begin"] [""] etc.
- [separator]: node separator such as [";"] [","] [""] ["+"] ["|"] etc.
- [closing]: closing string such as ["\}"] ["\]"] [")"] ["end"] [""] etc.
- [nodes]: elements of the list.
*)
type escape =
[ `None
| `Escape of
((string -> int -> int -> unit) -> string -> int -> int -> unit)
| `Escape_string of (string -> string) ]
type styles = (style_name * style) list
(** The regular pretty-printing functions *)
module Pretty :
sig
val define_styles : Format.formatter -> escape -> styles -> unit
val to_formatter : Format.formatter -> t -> unit
val to_buffer : ?escape:escape -> ?styles:styles -> Buffer.t -> t -> unit
val to_string : ?escape:escape -> ?styles:styles -> t -> string
val to_channel : ?escape:escape -> ?styles:styles -> out_channel -> t -> unit
val to_stdout : ?escape:escape -> ?styles:styles -> t -> unit
val to_stderr : ?escape:escape -> ?styles:styles -> t -> unit
end
(** No spacing or newlines other than those in the input data
or those produced by [Custom] printing. *)
module Compact :
sig
val to_buffer : Buffer.t -> t -> unit
val to_string : t -> string
val to_channel : out_channel -> t -> unit
val to_stdout : t -> unit
val to_stderr : t -> unit
val to_formatter : Format.formatter -> t -> unit
end
(**/**)
(** Deprecated. Predefined sets of parameters *)
module Param :
sig
val list_true : list_param
(** Deprecated. All boolean fields set to true. indent_body = 2. *)
val label_true : label_param
(** Deprecated. All boolean fields set to true. indent_after_label = 2. *)
val list_false : list_param
(** Deprecated. All boolean fields set to false. indent_body = 2. *)
val label_false : label_param
(** Deprecated. All boolean fields set to false. indent_after_label = 2. *)
end
================================================
FILE: src/refmt/.gitignore
================================================
git_version.ml
================================================
FILE: src/refmt/README.md
================================================
# Reason (For Native Compilers)
Simple, fast & type safe code that leverages the JavaScript & OCaml ecosystems.
This package provides support for using Reason with native OCaml compilers.
[](https://dev.azure.com/reasonml/reason/_build/latest?definitionId=2?branchName=master) [](https://travis-ci.org/facebook/reason) [](https://circleci.com/gh/facebook/reason/tree/master)
## [Native Quick Start With Esy](https://reasonml.github.io/docs/en/quickstart-ocaml)
## [Community](https://reasonml.github.io/docs/en/community.html)
## [Roadmap & Contribution](https://reasonml.github.io/docs/en/roadmap)
### Documentations
Go to https://github.com/reasonml/reasonml.github.io to contribute to the Reason documentation.
### Contributing
See the [docs folder's `GETTING_STARTED_CONTRIBUTING.md`](../docs/GETTING_STARTED_CONTRIBUTING.md).
================================================
FILE: src/refmt/dune
================================================
(executable
(public_name refmt)
(package reason)
(modes exe byte)
(modules refmt)
(flags :standard -open StdLabels)
(libraries refmt_lib))
(library
(public_name reason.refmt-lib)
(name refmt_lib)
(modules :standard \ refmt)
(flags :standard -open StdLabels)
(libraries reason cmdliner dune-build-info))
(rule
(with-stdout-to
git_commit.ml
(progn
(bash "echo let version = \\\"$(git rev-parse --verify HEAD)\\\"")
(bash "echo let short_version = \\\"$(git rev-parse --short HEAD)\\\""))))
(rule
(with-stdout-to
refmt.1
(run %{bin:refmt} --help=groff)))
(install
(section man)
(package reason)
(files refmt.1))
================================================
FILE: src/refmt/end_of_line.ml
================================================
type t =
| LF
| CRLF
module Detect = struct
let default = match Sys.win32 with true -> CRLF | _ -> LF
let get_eol_for_file =
let rec loop ic prev =
match input_char ic with
| '\n' -> (match prev with '\r' -> CRLF | _ -> LF)
| c -> loop ic c
in
fun filename ->
let ic = open_in_bin filename in
let eol = try loop ic ' ' with End_of_file -> default in
close_in ic;
eol
end
module Convert = struct
let lf_to_crlf =
let rec loop ~src i j ~dst ~len =
if i >= len
then ()
else
match String.unsafe_get src i with
| '\n' ->
Bytes.unsafe_set dst j '\r';
Bytes.unsafe_set dst (j + 1) '\n';
loop (i + 1) (j + 2) ~src ~dst ~len
| c ->
Bytes.unsafe_set dst j c;
loop (i + 1) (j + 1) ~src ~dst ~len
in
let rec count_newlines ~src ~src_len i acc =
if i >= src_len
then acc
else
match String.index_from src i '\n' with
| exception Not_found -> acc
| j -> count_newlines ~src ~src_len (j + 1) (acc + 1)
in
fun s ->
let len = String.length s in
match count_newlines ~src:s ~src_len:len 0 0 with
| 0 -> s
| nl_count ->
let dst = Bytes.create (len + nl_count) in
loop 0 0 ~src:s ~dst ~len;
Bytes.unsafe_to_string dst
let get_formatter =
let out_string (out_functions : Format.formatter_out_functions) eol =
fun s p n ->
match eol with
| LF -> out_functions.out_string s p n
| CRLF ->
let str = String.sub s ~pos:p ~len:n in
let str = lf_to_crlf str in
out_functions.out_string str 0 (String.length str)
in
fun output_channel eol ->
let f = Format.formatter_of_out_channel output_channel in
let new_functions =
let out_functions = Format.pp_get_formatter_out_functions f () in
{ out_functions with out_string = out_string out_functions eol }
in
Format.pp_set_formatter_out_functions f new_functions;
f
end
================================================
FILE: src/refmt/end_of_line.mli
================================================
type t =
| LF
| CRLF
module Detect : sig
val default : t
val get_eol_for_file : string -> t
end
module Convert : sig
val get_formatter : out_channel -> t -> Format.formatter
end
================================================
FILE: src/refmt/git_commit.mli
================================================
(* Interface file to ensure git_commit is generated properly with dune *)
val version : string
val short_version : string
================================================
FILE: src/refmt/package.ml
================================================
let version =
match Build_info.V1.version () with
| None -> "n/a"
| Some v -> Build_info.V1.Version.to_string v
let git_version = Git_commit.version
let git_short_version = Git_commit.short_version
================================================
FILE: src/refmt/package.mli
================================================
val version : string
val git_version : string
val git_short_version : string
================================================
FILE: src/refmt/printer_maker.ml
================================================
open Reason
type 'a parser_result =
{ ast : 'a
; comments : Reason_comment.t list
; parsed_as_ml : bool
; parsed_as_intf : bool
}
type parse_itype =
[ `ML
| `Reason
| `Binary
| `BinaryReason
| `Auto
]
type print_itype =
[ `ML
| `Reason
| `Binary
| `BinaryReason
| `AST
| `None
]
exception Invalid_config of string
module type PRINTER = sig
type t
val parse :
use_stdin:bool
-> parse_itype
-> string
-> (t * Reason_comment.t list) * bool
val print :
print_itype
-> string
-> bool
-> out_channel
-> Format.formatter
-> t * Reason_comment.t list
-> unit
end
let err s = raise (Invalid_config s)
let prepare_output_file = function
| Some name -> open_out_bin name
| None ->
set_binary_mode_out stdout true;
stdout
let close_output_file output_file output_chan =
match output_file with Some _ -> close_out output_chan | None -> ()
let ocamlBinaryParser use_stdin filename =
let module Ast_io = Ppxlib__.Utils.Ast_io in
let input_source =
match use_stdin with true -> Ast_io.Stdin | false -> File filename
in
match Ast_io.read input_source ~input_kind:Necessarily_binary with
| Error _ -> assert false
| Ok { ast = Impl ast; _ } ->
{ ast = Obj.magic ast
; comments = []
; parsed_as_ml = true
; parsed_as_intf = false
}
| Ok { ast = Intf ast; _ } ->
{ ast = Obj.magic ast
; comments = []
; parsed_as_ml = true
; parsed_as_intf = true
}
let reasonBinaryParser use_stdin filename =
let chan =
match use_stdin with
| true -> stdin
| false ->
let file_chan = open_in_bin filename in
seek_in file_chan 0;
file_chan
in
let _, _, ast, comments, parsed_as_ml, parsed_as_intf = input_value chan in
{ ast; comments; parsed_as_ml; parsed_as_intf }
================================================
FILE: src/refmt/printer_maker.mli
================================================
open Reason
type 'a parser_result =
{ ast : 'a
; comments : Reason_comment.t list
; parsed_as_ml : bool
; parsed_as_intf : bool
}
type parse_itype =
[ `ML
| `Reason
| `Binary
| `BinaryReason
| `Auto
]
type print_itype =
[ `ML
| `Reason
| `Binary
| `BinaryReason
| `AST
| `None
]
exception Invalid_config of string
module type PRINTER = sig
type t
val parse :
use_stdin:bool
-> parse_itype
-> string
-> (t * Reason_comment.t list) * bool
val print :
print_itype
-> string
-> bool
-> out_channel
-> Format.formatter
-> t * Reason_comment.t list
-> unit
end
val err : string -> 'a
val ocamlBinaryParser : bool -> string -> 'a parser_result
val reasonBinaryParser : bool -> string -> 'a parser_result
val prepare_output_file : string option -> out_channel
val close_output_file : string option -> out_channel -> unit
================================================
FILE: src/refmt/reason_implementation_printer.ml
================================================
open Reason
open Ppxlib
type t = Parsetree.structure
let err = Printer_maker.err
(* Note: filename should only be used with .ml files. See reason_toolchain. *)
let defaultImplementationParserFor use_stdin filename =
let open Reason_toolchain in
let theParser, parsedAsML =
if Filename.check_suffix filename ".re"
then RE.implementation_with_comments, false
else if Filename.check_suffix filename ".ml"
then ML.implementation_with_comments, true
else
err
("Cannot determine default implementation parser for filename '"
^ filename
^ "'.")
in
let ast, comments = theParser (setup_lexbuf ~use_stdin filename) in
{ Printer_maker.ast
; comments
; parsed_as_ml = parsedAsML
; parsed_as_intf = false
}
let parse ~use_stdin filetype filename =
let { Printer_maker.ast
; comments
; parsed_as_ml = parsedAsML
; parsed_as_intf = parsedAsInterface
}
=
match filetype with
| `Auto -> defaultImplementationParserFor use_stdin filename
| `BinaryReason -> Printer_maker.reasonBinaryParser use_stdin filename
| `Binary -> Printer_maker.ocamlBinaryParser use_stdin filename
| `ML ->
let lexbuf = Reason_toolchain.setup_lexbuf ~use_stdin filename in
let impl = Reason_toolchain.ML.implementation_with_comments in
let ast, comments = impl lexbuf in
{ ast; comments; parsed_as_ml = true; parsed_as_intf = false }
| `Reason ->
let lexbuf = Reason_toolchain.setup_lexbuf ~use_stdin filename in
let impl = Reason_toolchain.RE.implementation_with_comments in
let ast, comments = impl lexbuf in
{ ast; comments; parsed_as_ml = false; parsed_as_intf = false }
in
if parsedAsInterface
then err "The file parsed does not appear to be an implementation file."
else (ast, comments), parsedAsML
let print printtype filename parsedAsML output_chan output_formatter =
match printtype with
| `BinaryReason ->
fun (ast, comments) ->
(* Our special format for interchange between reason should keep the
* comments separate. This is not compatible for input into the
* ocaml compiler - only for input into another version of Reason. We
* also store whether or not the binary was originally *parsed* as an
* interface file.
*)
output_value
output_chan
( Ocaml_common.Config.ast_impl_magic_number
, filename
, ast
, comments
, parsedAsML
, false )
| `Binary ->
fun (ast, _) ->
let ast =
ast
|> Reason_syntax_util.(
apply_mapper_to_structure remove_stylistic_attrs_mapper)
|> Reason_syntax_util.(apply_mapper_to_structure backport_letopt_mapper)
in
Ppxlib__.Utils.Ast_io.write
output_chan
{ Ppxlib__.Utils.Ast_io.input_name = filename
; input_version =
Obj.magic
(module Ppxlib_ast.Compiler_version : Ppxlib_ast.OCaml_version)
; ast = Impl ast
}
~add_ppx_context:false
| `AST ->
fun (ast, _) ->
Ocaml_common.Printast.implementation
output_formatter
(Reason_toolchain.To_current.copy_structure ast)
| `None -> fun _ -> ()
| `ML ->
Reason_toolchain.ML.print_implementation_with_comments output_formatter
| `Reason ->
Reason_toolchain.RE.print_implementation_with_comments output_formatter
================================================
FILE: src/refmt/reason_implementation_printer.mli
================================================
include Printer_maker.PRINTER
================================================
FILE: src/refmt/reason_interface_printer.ml
================================================
open Reason
open Ppxlib
type t = Parsetree.signature
let err = Printer_maker.err
(* Note: filename should only be used with .mli files. See reason_toolchain. *)
let defaultInterfaceParserFor use_stdin filename =
let open Reason_toolchain in
let theParser, parsedAsML =
if Filename.check_suffix filename ".rei"
then RE.interface_with_comments, false
else if Filename.check_suffix filename ".mli"
then ML.interface_with_comments, true
else
err
("Cannot determine default interface parser for filename '"
^ filename
^ "'.")
in
let ast, comments = theParser (setup_lexbuf ~use_stdin filename) in
{ Printer_maker.ast
; comments
; parsed_as_ml = parsedAsML
; parsed_as_intf = true
}
let parse ~use_stdin filetype filename =
let { Printer_maker.ast
; comments
; parsed_as_ml = parsedAsML
; parsed_as_intf = parsedAsInterface
}
=
match filetype with
| `Auto -> defaultInterfaceParserFor use_stdin filename
| `BinaryReason -> Printer_maker.reasonBinaryParser use_stdin filename
| `Binary -> Printer_maker.ocamlBinaryParser use_stdin filename
| `ML ->
let lexbuf = Reason_toolchain.setup_lexbuf ~use_stdin filename in
let intf = Reason_toolchain.ML.interface_with_comments in
let ast, comments = intf lexbuf in
{ ast; comments; parsed_as_ml = true; parsed_as_intf = true }
| `Reason ->
let lexbuf = Reason_toolchain.setup_lexbuf ~use_stdin filename in
let intf = Reason_toolchain.RE.interface_with_comments in
let ast, comments = intf lexbuf in
{ ast; comments; parsed_as_ml = false; parsed_as_intf = true }
in
if not parsedAsInterface
then err "The file parsed does not appear to be an interface file."
else (ast, comments), parsedAsML
let print printtype filename parsedAsML output_chan output_formatter =
match printtype with
| `BinaryReason ->
fun (ast, comments) ->
(* Our special format for interchange between reason should keep the
* comments separate. This is not compatible for input into the
* ocaml compiler - only for input into another version of Reason. We
* also store whether or not the binary was originally *parsed* as an
* interface file.
*)
output_value
output_chan
( Ocaml_common.Config.ast_intf_magic_number
, filename
, ast
, comments
, parsedAsML
, true )
| `Binary ->
fun (ast, _) ->
let ast =
ast
|> Reason_syntax_util.(
apply_mapper_to_signature remove_stylistic_attrs_mapper)
|> Reason_syntax_util.(apply_mapper_to_signature backport_letopt_mapper)
in
Ppxlib__.Utils.Ast_io.write
output_chan
{ Ppxlib__.Utils.Ast_io.input_name = filename
; input_version =
Obj.magic
(module Ppxlib_ast.Compiler_version : Ppxlib_ast.OCaml_version)
; ast = Intf ast
}
~add_ppx_context:false
| `AST ->
fun (ast, _) ->
Ocaml_common.Printast.interface
output_formatter
(Reason_toolchain.To_current.copy_signature ast)
| `None -> fun _ -> ()
| `ML -> Reason_toolchain.ML.print_interface_with_comments output_formatter
| `Reason ->
Reason_toolchain.RE.print_interface_with_comments output_formatter
================================================
FILE: src/refmt/reason_interface_printer.mli
================================================
include Printer_maker.PRINTER
================================================
FILE: src/refmt/refmt.ml
================================================
(* Copyright (c) 2015-present, Facebook, Inc.
*
* This source code is licensed under the MIT license found in the
* LICENSE file in the root directory of this source tree.
*)
open Reason
open Cmdliner
open Refmt_lib
let read_text_lines file =
let list = ref [] in
let chan = open_in file in
try
while true do
list := input_line chan :: !list
done;
[]
with
| End_of_file ->
close_in chan;
List.rev !list
let refmt
interface
is_recoverable
explicit_arity
parse_ast
print
print_width
heuristics_file
in_place
input_files
=
let refmt_single input_file =
let use_stdin, input_file =
match input_file with Some name -> false, name | None -> true, ""
in
let eol =
match use_stdin, input_file with
| true, _ -> End_of_line.Detect.default
| false, name -> End_of_line.Detect.get_eol_for_file name
in
let parse_ast =
match parse_ast, use_stdin with
| Some x, _ -> x
| None, false -> `Auto
| None, true -> `Reason (* default *)
in
let constructorLists =
match heuristics_file with
| Some f_name -> read_text_lines f_name
| None -> []
in
let interface =
match interface with
| true -> true
| false ->
Filename.check_suffix input_file ".rei"
|| Filename.check_suffix input_file ".mli"
in
let output_file =
match in_place, use_stdin with
| true, true -> Printer_maker.err "Cannot write in place to stdin."
| true, _ -> Some input_file
| false, _ -> None
in
let (module Printer : Printer_maker.PRINTER) =
if interface
then (module Reason_interface_printer)
else (module Reason_implementation_printer)
in
Reason_config.configure ~recoverable:is_recoverable;
Location.input_name := input_file;
let _ =
Reason_pprint_ast.configure
~width:print_width
~assumeExplicitArity:explicit_arity
~constructorLists
in
let ast, parsedAsML = Printer.parse ~use_stdin parse_ast input_file in
let output_chan = Printer_maker.prepare_output_file output_file in
(* If you run into trouble with this (or need to use std_formatter by itself
at the same time for some reason), try breaking this out so that it's not
possible to call Format.formatter_of_out_channel on stdout. *)
let output_formatter = End_of_line.Convert.get_formatter output_chan eol in
Printer.print print input_file parsedAsML output_chan output_formatter ast;
(* Also closes all open boxes. *)
Format.pp_print_flush output_formatter ();
flush output_chan;
Printer_maker.close_output_file output_file output_chan
in
try
match input_files with
| [] -> `Ok (refmt_single None)
| _ -> `Ok (List.iter ~f:(fun file -> refmt_single (Some file)) input_files)
with
| Printer_maker.Invalid_config msg -> `Error (true, msg)
| Reason_errors.Reason_error (error, loc) ->
Reason_errors.report_error Format.err_formatter ~loc error;
exit 1
| exn ->
prerr_endline (Printexc.to_string exn);
(* FIXME: Reason_syntax_util.report_error Format.err_formatter exn; *)
exit 1
let () =
let examples =
let split_lines s =
let rec loop ~last_is_cr ~acc i j =
if j = String.length s
then
let acc =
if j = i || (j = i + 1 && last_is_cr)
then acc
else String.sub s ~pos:i ~len:(j - i) :: acc
in
List.rev acc
else
match s.[j] with
| '\r' -> loop ~last_is_cr:true ~acc i (j + 1)
| '\n' ->
let line =
let len = if last_is_cr then j - i - 1 else j - i in
String.sub s ~pos:i ~len
in
loop ~acc:(line :: acc) (j + 1) (j + 1) ~last_is_cr:false
| _ -> loop ~acc i (j + 1) ~last_is_cr:false
in
loop ~acc:[] 0 0 ~last_is_cr:false
in
let[@tail_mod_cons] rec concat_map f = function
| [] -> []
| x :: xs -> prepend_concat_map (f x) f xs
and[@tail_mod_cons] prepend_concat_map ys f xs =
match ys with
| [] -> concat_map f xs
| y :: ys -> y :: prepend_concat_map ys f xs
in
function
| [] -> `Blocks []
| _ :: _ as examples ->
let block_of_example index (intro, ex) =
let prose = `I (string_of_int (index + 1) ^ ".", String.trim intro ^ ":")
and code_lines =
ex
|> String.trim
|> split_lines
|> concat_map (fun codeline ->
[ `Noblank; `Pre (" " ^ codeline) ])
(* suppress initial blank *)
|> List.tl
in
`Blocks (prose :: code_lines)
in
let example_blocks = List.mapi examples ~f:block_of_example in
`Blocks (`S "EXAMPLES" :: example_blocks)
in
let refmt_t =
let top_level_info =
let doc = "Reason's Parser & Pretty-printer" in
let man =
[ `S "DESCRIPTION"
; `P
"refmt lets you format Reason files, parse them, and convert them \
between OCaml syntax and Reason syntax."
; examples
[ "Initialise a new project named `foo'", "dune init project foo"
; "Format a Reason implementation file", "refmt file.re"
; "Format a Reason interface file", "refmt file.rei"
; ( "Format interface code from the command line"
, "echo 'let x: int' | refmt --interface=true" )
; "Convert an OCaml file to Reason", "refmt file.ml"
; "Convert a Reason file to OCaml", "refmt file.re --print ml"
; ( "Convert OCaml from the command line to Reason"
, "echo 'let x = 1' | refmt --parse ml" )
]
]
in
let version =
"Reason " ^ Package.version ^ " @ " ^ Package.git_short_version
in
Cmd.info "refmt" ~version ~doc ~man
in
let open Term in
let open Refmt_args in
let term =
const refmt
$ interface
$ recoverable
$ explicit_arity
$ parse_ast
$ print
$ print_width
$ heuristics_file
$ in_place
$ input
in
Cmd.v top_level_info (Term.ret term)
in
match Cmd.eval_value' refmt_t with
| `Exit 0 -> exit 0
| `Exit _ -> exit 1
| _ -> exit 0
================================================
FILE: src/refmt/refmt_args.ml
================================================
open Cmdliner
let interface =
let doc = "parse AST as an interface" in
Arg.(value & opt bool false & info [ "i"; "interface" ] ~doc)
let recoverable =
let doc = "enable recoverable parser" in
Arg.(value & flag & info [ "r"; "recoverable" ] ~doc)
let explicit_arity =
let doc =
"if a constructor's argument is a tuple, always interpret it as multiple \
arguments"
in
Arg.(value & flag & info [ "e"; "assume-explicit-arity" ] ~doc)
let parse_ast =
let docv = "FORM" in
let doc =
"parse AST in FORM, which is one of: (ml | re | binary (for compiler \
input) | binary_reason (for interchange between Reason versions))"
in
let opts =
Arg.enum
[ "ml", `ML
; "re", `Reason
; "binary", `Binary
; "binary_reason", `BinaryReason
; "auto", `Auto
]
in
Arg.(value & opt (some opts) None & info [ "parse" ] ~docv ~doc)
let print =
let docv = "FORM" in
let doc =
"print AST in FORM, which is one of: (ml | re (default) | binary (for \
compiler input) | binary_reason (for interchange between Reason versions) \
| ast (print human readable AST directly) | none)"
in
let opts =
Arg.enum
[ "ml", `ML
; "re", `Reason
; "binary", `Binary
; "binary_reason", `BinaryReason
; "ast", `AST
; "none", `None
]
in
Arg.(value & opt opts `Reason & info [ "p"; "print" ] ~docv ~doc)
let print_width =
let docv = "COLS" in
let doc = "wrapping width for printing the AST" in
let env = Cmd.Env.info "REFMT_PRINT_WIDTH" ~doc in
Arg.(value & opt int 80 & info [ "w"; "print-width" ] ~docv ~doc ~env)
let heuristics_file =
let doc =
"load path as a heuristics file to specify which constructors carry a \
tuple rather than multiple arguments. Mostly used in removing \
[@implicit_arity] introduced from OCaml conversion.\n\
\t\texample.txt:\n\
\t\tConstructor1\n\
\t\tConstructor2"
in
Arg.(value & opt (some file) None & info [ "h"; "heuristics-file" ] ~doc)
let in_place =
let doc = "reformat a file in-place" in
Arg.(value & flag & info [ "in-place" ] ~doc)
let input =
let docv = "FILENAMES" in
let doc = "input files; if empty, assume stdin" in
Arg.(value & pos_all non_dir_file [] & info [] ~docv ~doc)
================================================
FILE: src/vendored-omp/LICENSE.md
================================================
In the following, "this library" refers to all files marked
"Copyright INRIA" in this distribution.
The OCaml Core System is distributed under the terms of the
GNU Lesser General Public License (LGPL) version 2.1 (included below).
As a special exception to the GNU Lesser General Public License, you
may link, statically or dynamically, a "work that uses the OCaml Core
System" with a publicly distributed version of this library
to produce an executable file containing portions of the OCaml Core
System, and distribute that executable file under terms of your
choice, without any of the additional requirements listed in clause 6
of the GNU Lesser General Public License. By "a publicly distributed
version of this library", we mean either the unmodified OCaml
Core System as distributed by INRIA, or a modified version of the
OCaml Core System that is distributed under the conditions defined in
clause 2 of the GNU Lesser General Public License. This exception
does not however invalidate any other reasons why the executable file
might be covered by the GNU Lesser General Public License.
----------------------------------------------------------------------
GNU LESSER GENERAL PUBLIC LICENSE
Version 2.1, February 1999
Copyright (C) 1991, 1999 Free Software Foundation, Inc.
51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
[This is the first released version of the Lesser GPL. It also counts
as the successor of the GNU Library Public License, version 2, hence
the version number 2.1.]
Preamble
The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users.
This license, the Lesser General Public License, applies to some specially designated software packages--typically libraries--of the Free Software Foundation and other authors who decide to use it. You can use it too, but we suggest you first think carefully about whether this license or the ordinary General Public License is the better strategy to use in any particular case, based on the explanations below.
When we speak of free software, we are referring to freedom of use, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish); that you receive source code or can get it if you want it; that you can change the software and use pieces of it in new free programs; and that you are informed that you can do these things.
To protect your rights, we need to make restrictions that forbid distributors to deny you these rights or to ask you to surrender these rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library or if you modify it.
For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link other code with the library, you must provide complete object files to the recipients, so that they can relink them with the library after making changes to the library and recompiling it. And you must show them these terms so they know their rights.
We protect your rights with a two-step method: (1) we copyright the library, and (2) we offer you this license, which gives you legal permission to copy, distribute and/or modify the library.
To protect each distributor, we want to make it very clear that there is no warranty for the free library. Also, if the library is modified by someone else and passed on, the recipients should know that what they have is not the original version, so that the original author's reputation will not be affected by problems that might be introduced by others.
Finally, software patents pose a constant threat to the existence of any free program. We wish to make sure that a company cannot effectively restrict the users of a free program by obtaining a restrictive license from a patent holder. Therefore, we insist that any patent license obtained for a version of the library must be consistent with the full freedom of use specified in this license.
Most GNU software, including some libraries, is covered by the ordinary GNU General Public License. This license, the GNU Lesser General Public License, applies to certain designated libraries, and is quite different from the ordinary General Public License. We use this license for certain libraries in order to permit linking those libraries into non-free programs.
When a program is linked with a library, whether statically or using a shared library, the combination of the two is legally speaking a combined work, a derivative of the original library. The ordinary General Public License therefore permits such linking only if the entire combination fits its criteria of freedom. The Lesser General Public License permits more lax criteria for linking other code with the library.
We call this license the "Lesser" General Public License because it does Less to protect the user's freedom than the ordinary General Public License. It also provides other free software developers Less of an advantage over competing non-free programs. These disadvantages are the reason we use the ordinary General Public License for many libraries. However, the Lesser license provides advantages in certain special circumstances.
For example, on rare occasions, there may be a special need to encourage the widest possible use of a certain library, so that it becomes a de-facto standard. To achieve this, non-free programs must be allowed to use the library. A more frequent case is that a free library does the same job as widely used non-free libraries. In this case, there is little to gain by limiting the free library to free software only, so we use the Lesser General Public License.
In other cases, permission to use a particular library in non-free programs enables a greater number of people to use a large body of free software. For example, permission to use the GNU C Library in non-free programs enables many more people to use the whole GNU operating system, as well as its variant, the GNU/Linux operating system.
Although the Lesser General Public License is Less protective of the users' freedom, it does ensure that the user of a program that is linked with the Library has the freedom and the wherewithal to run that program using a modified version of the Library.
The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, whereas the latter must be combined with the library in order to run.
TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
0. This License Agreement applies to any software library or other program which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Lesser General Public License (also called "this License"). Each licensee is addressed as "you".
A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables.
The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".)
"Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library.
Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does.
1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library.
You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee.
2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions:
a) The modified work must itself be a software library.
b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change.
c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License.
d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful.
(For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.)
These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it.
Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library.
In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License.
3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices.
Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy.
This option is useful when you wish to copy part of the code of the Library into a program that is not a library.
4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange.
If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code.
5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License.
However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables.
When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law.
If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.)
Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself.
6. As an exception to the Sections above, you may also combine or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications.
You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things:
a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.)
b) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (1) uses at run time a copy of the library already present on the user's computer system, rather than copying library functions into the executable, and (2) will operate properly with a modified version of the library, if the user installs one, as long as the modified version is interface-compatible with the version that the work was made with.
c) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution.
d) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place.
e) Verify that the user has already received a copy of these materials or that you have already sent this user a copy.
For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the materials to be distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable.
It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute.
7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things:
a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above.
b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work.
8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance.
9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it.
10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties with this License.
11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library.
If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances.
It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice.
This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License.
12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License.
13. The Free Software Foundation may publish revised and/or new versions of the Lesser General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns.
Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation.
14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally.
NO WARRANTY
15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
END OF TERMS AND CONDITIONS
How to Apply These Terms to Your New Libraries
If you develop a new library, and you want it to be of the greatest possible use to the public, we recommend making it free software that everyone can redistribute and change. You can do so by permitting redistribution under these terms (or, alternatively, under the terms of the ordinary General Public License).
To apply these terms, attach the following notices to the library. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found.
one line to give the library's name and an idea of what it does.
Copyright (C) year name of author
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
Also add information on how to contact you by electronic and paper mail.
You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the library, if necessary. Here is a sample; alter the names:
Yoyodyne, Inc., hereby disclaims all copyright interest in
the library `Frob' (a library for tweaking knobs) written
by James Random Hacker.
signature of Ty Coon, 1 April 1990
Ty Coon, President of Vice
That's all there is to it!
--------------------------------------------------
================================================
FILE: src/vendored-omp/MANUAL.md
================================================
Title: Guide to OCaml Migrate Parsetree
Author: Frédéric Bour, @let-def
Date: March 9, 2017
**Table of Contents**
- [Manipulating parsetree](#manipulating-parsetree)
- [Talking about different versions of the compiler](#talking-about-different-versions-of-the-compiler)
- [Migrating between compiler versions](#migrating-between-compiler-versions)
- [(Un)marshalling AST](#unmarshalling-ast)
- [Drivers](#drivers)
- [The legacy way](#the-legacy-way)
- [New registration interface](#new-registration-interface)
- [A minimal driver](#a-minimal-driver)
- [Custom and standalone drivers](#custom-and-standalone-drivers)
- [ppx_tools_versioned](#ppx_tools_versioned)
- [ppx_metaquots](#ppx_metaquots)
- [Findlib specification](#findlib-specification)
- [Standalone *"--as-ppx"* rewriters in META](#standalone---as-ppx-rewriters-in-meta)
- [Using arguments in META ppxopt](#using-arguments-in-meta-ppxopt)
- [Conventions for distributing a linkable ppx rewriter](#conventions-for-distributing-a-linkable-ppx-rewriter)
- [Troubleshooting](#troubleshooting)
- [Accessing shadowed compiler libs module](#accessing-shadowed-compiler-libs-module)
- [Using functions from compiler-libs results in (unfriendly) type errors](#using-functions-from-compiler-libs-results-in-unfriendly-type-errors)
- [Features not supported in targeted version](#features-not-supported-in-targeted-version)
- [What kind of guarantees to expect in practice?](#what-kind-of-guarantees-to-expect-in-practice)
This library is designed to make PPX rewriters portable across compiler versions.
It works by versioning the definitions of OCaml AST. This includes `Parsetree`, `Asttypes`, `Outcometree`, `Ast_helper` and most of `Docstrings` and `Ast_mapper`.
*Note:* `Docstrings` and `Ast_mapper` contain some global state which was removed during versioning. This affect registration of rewriters when using `Ast_mapper` as a driver. See the [driver section](#drivers) for reliable solutions.
# Manipulating parsetree
Most of the work happens by shadowing. If your PPX rewriter was written against OCaml 4.04 AST, just `open Ast_404` (alternatively, you can pass `-open Ast_404` when building the file).
This will introduce the versioned modules in scope. When compiled with other supported versions of OCaml, the definitions are still compatible with 4.04.
While this is enough to manipulate the AST from within your code, you can no longer have expectations on the version of `compiler-libs`. The rest of the `Migrate_parsetree` module provides tools to deal with that.
## Talking about different versions of the compiler
The module `Migrate_parsetree.Versions` provides a way of abstracting compiler versions and getting functions to migrate from one version to another.
The interface of the module is quite technical, but one doesn't need to understand all details to work with the module.
The main problem that it solves is being able to talk about a "signature" or "structure" without being tied to a specific compiler version (that is, while being polymorphic over concrete versions of the compiler).
The module type `Ast` lists all the types that are abstracted for each version. The type `ocaml_version` and the module type `OCaml_version` represent ocaml versions in the term and module languages.
Instances are given by the values `ocaml_402`, `ocaml_403`, ... and the modules `OCaml_402`, `OCaml_403`...
The `ocaml_current` and `OCaml_current` definitions are special in that they refer to versions compatible with compiler-libs (the current compiler).
Functions and functors that operate across compiler versions will take these as arguments.
## Migrating between compiler versions
When migrating between two known compiler versions, the modules `Migrate_parsetree.Migrate_40x_40y` contain functions to transform values between two consecutive versions.
For instance `Migrate_402_403.copy_signature` turns a signature of OCaml 4.02 into a signature for OCaml 4.03. `Migrate_404_403.copy_mapper` transforms an `Ast_mapper.mapper` for OCaml 4.04 into a mapper for OCaml 4.03.
When working with an arbitrary version, it becomes useful to quantify over versions and migrations. The `Migrate_parsetree.Versions` module comes again to the rescue.
The `migrate_functions` record is a list of functions for converting each type.
The function `Versions.migrate` takes two OCaml version and returns a migration record between the two. The functor `Convert` does the same at the module level.
## (Un)marshalling AST
The `Ast_io` module implements AST marshalling and unmarshalling abstracted over OCaml versions.
It can read and write binary implementation and interface files from different compiler versions and pack them with the corresponding `Versions.OCaml_version` module.
(FIXME: marshalling format is not guaranteed to be stable accross versions)
## Parsing source file
The `Parse` module implements an interface similar to the one from compiler-libs, but parsing functions take an OCaml version as first argument.
It uses the distributed OCaml parser (current version) then migrate the resulting AST to the requested version. Beware, these parsing functions can alse raise `Migration_error` exceptions.
# Driver
So far, all tools presented were for working with parsetrees. This is helpful to implement a mapper object, but it is not enough to get to a PPX binary.
Drivers fulfill this last step: going from one or more AST mappers to a concrete binary that will do the rewriting.
## The legacy way
Traditionally, mappers had to be registered in `Ast_mapper`; either with `Ast_mapper.register` or `Ast_mapper.run_main`.
The registration interface was removed from versioned modules. If you try to register with `Ast_mapper` from compiler-libs, remember to migrate the version.
In a few lines of code:
```ocaml
(* Assuming rewriter is written against OCaml 4.04 parsetree *)
let migration =
Versions.migrate Versions.ocaml_404 Versions.ocaml_current
let () =
(* Refer to unshadowed mapper *)
Compiler_libs.Ast_mapper.register
(fun args -> migration.copy_mapper (my_mapper args))
```
This method might be convenient for quickly migrating existing rewriters, but we are trying to get away from `Ast_mapper` global state.
*ocaml-migrate-parsetree* offers a new, forward looking, interface.
## New registration interface
In the new interface, the state that can be accessed by a PPX rewriter is made more explicit.
- *Compiler configuration* via `Driver.config`; it snapshots the few compiler settings that are guaranteed to be set by the compiler API.
- *Cookies* via `Driver.cookies`, `get_cookies` and `set_cookies`, which work across different versions.
- *Command-line arguments*; when registering a mapper, one can provide argument specifications, as defined by the [`Arg`](http://caml.inria.fr/pub/docs/manual-ocaml/libref/Arg.html) module.
Rewriters no longer receive an arbitrary list of arguments. Everything happens through the specifications. Collision in rewriter names and argument keys is *an error*: a rewriter should be registered only once, each key should be used only once.
```ocaml
open Ast_404 (* Target 4.04 parsetree *)
(* Rewriter settings *)
let foo_config : string option ref = ref None
let set_foo bar = foo_config := Some bar
let reset_args () = foo_config := None
let args = [
("-foo", Arg.String set_foo, "<bar> Foo value to use in the rewriter")
]
(* Rewriter implementation *)
let my_rewriter config cookies =
let foo = match !foo_config with
| None -> raise (Arg.Bad "-foo is mandatory")
| Some foo -> foo
in
{Ast_mapper.default_mapper with ...}
(* Registration *)
let () =
Driver.register ~name:"hello_world" ~reset_args ~args
Versions.ocaml_404 my_rewriter
```
## A minimal driver
The code above gets the rewriter registered, but this won't produce a runnable binary. One or more rewriters can be registered, the final step will be to run them.
`Driver.run_as_ast_mapper` is suitable as an argument to `Ast_mapper.run_main` (or even `Ast_mapper.register`). It acts as a "meta-mapper" that will apply all the registered mappers.
`Driver.run_as_ppx_rewriter` does that, calling `Ast_mapper.run_main Driver.run_as_ast_mapper`.
The order is chosen to minimize the number of rewriting that happens:
- rewriters are sorted by versions, lower versions first
- rewriters targeting the same version are applied in the registration order
## Custom and standalone drivers
Using `Driver.run_main` as an entry point offers a way to make custom and standalone rewriters.
A standalone rewriter can be used independently of the OCaml compiler.
It can rewrite source files or save processed ASTs. Try `./myrewriter --help` for more information.
When the first argument is "--as-ppx", it behaves like a normal PPX and is suitable for use with "-ppx" (`ocamlc -ppx "./myrewriter --as-ppx"`).
Linking the `ocaml-migrate-parsetree.driver-main` package has the effect of just calling `Driver.run_main`. It should be linked last.
The purpose is to let you make a custom rewriter that link all the PPX in use in your project to reduce the overhead of rewriting:
```shell
ocamlfind ocamlopt -linkpkg -package rewriter1,rewriter2,... \
-package ocaml-migrate-parsetree.driver-main -o myrewriter
```
# ppx_tools_versioned
Some rewriters make use of the *ppx_tools* package that offers conveniences for manipulating parsetrees. As *ppx_tools* itself uses compiler-libs, using it directly defeats the purpose of *ocaml-migrate-parsetree*.
We provide the [ppx_tools_versioned](https://github.com/let-def/ppx_tools_versioned) package to overcome this. It offers migrate friendly versions of `Ast_convenience`, `Ast_lifter`, `Ast_mapper_class` and `Ppx_metaquot`.
To use these versions, just append `_40x` to the module names or `open Ppx_tool_40x` module.
```ocaml
(* Original code *)
open Ast_mapper_class
class my_mapper =
object
inherit mapper
...
end
(* Targeting 4.04 *)
open Ast_404
open Ppx_tools_404
open Ast_mapper_class
class my_mapper =
object
inherit mapper
...
end
(* Alternatively, if you use a single module from Ppx_tools *)
open Ast_mapper_class_404
class my_mapper =
object
inherit mapper
...
end
```
### ppx_metaquots
The *metaquot* rewriter allows quoting of the OCaml AST. The version provided by *ppx_tools* will quote the Parsetree from *compiler-libs*.
The versioned ones are accessed by using *ppx_tools_versioned.metaquot_40x* packages.
For instance, *ppx_tools_versioned.metaquot_404* will quote `Ast_404.Parsetree`.
# Findlib specification
Some precautions have to be taken when writing *META* files for *ocaml-migrate-parsetree* driven PPXs. The ppx and ppxopt directives are affected.
## Standalone *"--as-ppx"* rewriters in META
If your rewriter is produced as standalone rewriter, then you have to pass the "--as-ppx" argument first:
```diff
-ppx = "./my_ppx"
+ppx = "./my_ppx --as-ppx"
```
As long as the PPX command line begins with `./`, findlib will expand the path to an absolute directory and you will get the correct invocation:
```
/home/me/.opam/.../my_lib/./my_ppx --as-ppx
```
## Using arguments in META ppxopt
Since rewriters use the `Arg` module to specify command-line arguments, anonymous arguments are no longer allowed.
If you used to pass anonymous arguments with ppxopt, you should pick an argument name and prefix them. For instance:
```
-ppxopt = "my_ppx,./bar"
+ppxopt = "my_ppx,-foo,./bar"
```
As you can see, arguments are separated by commas. Commas ensure that filename expansion still happens, such that invocation looks like:
```
/home/me/.opam/.../my_lib/./my_ppx ... -foo /home/me/.opam/.../my_lib/./bar
```
## Conventions for distributing a linkable ppx rewriter
The common case is to run ppx binaries on-demand: a findlib package describing a ppx rewriter will essentially add a new `-ppx my_binary` argument to the compiler invocation.
It is also possible to link and run a dedicated binary that will apply many rewriters consecutively. A package following that convention will use *ocaml-migrate-parsetree* to register a rewriter using `Driver.register`, but not do any actual rewriting (no `-ppx ...`).
The build system of a project making use of this feature will first build a custom rewriter that links all the necessary packages to produce a first binary. This binary is then used as the only ppx rewriter for the main source files of this project.
The convention to distinguish when a ppx package is used as a rewriter and when it is used a library is to use two findlib predicates (see [META](http://projects.camlcity.org/projects/dl/findlib-1.7.1/doc/ref-html/r759.html) documentation and also `ocamlfind(1)` man page):
- `custom_ppx`: we are building a custom ppx driver, no rewriting should be done now (in other words, don't pass `-ppx ...` argument)
- `ppx_driver`: we are making our own driver, registration should be done using `Driver.register`
### Linking example
```shell
$ ocamlfind opt -o my_driver -linkpkg -predicates custom_ppx,ppx_driver -package ppx_tools_versioned.metaquot_402 -package ocaml-migrate-parsetree.driver-main
```
The predicates change the behavior of `ppx_tools_versioned.metaquot_402` package. Linking `ocaml-migrate-parsetree.driver-main` lasts executes all the rewriters that were registered.
### Package example
META
```
version = "1.0"
description = "dummy ppx"
requires = "ocaml-migrate-parsetree"
ppx(-custom_ppx,-ppx_driver) = "./ppx_dummy --as-ppx"
archive(byte,ppx_driver) = "ppx_dummy.cma"
archive(native,ppx_driver) = "ppx_dummy.cmxa"
```
Rewrite only when `custom_ppx` is not defined.
Link *ppx_dummy* objects when `ppx_driver` is defined.
# Troubleshooting
## Accessing shadowed compiler libs module
`Migrate_parsetree` defines a `Compiler_libs` module that reexports all modules that could have been shadowed by `Ast_40x` modules.
## Using functions from compiler-libs results in (unfriendly) type errors
Remember that because of abstraction, most values manipulated from within the rewriter have types that are unrelated to compiler-libs definitions.
For instance, you cannot directly use `Pprintast.core_type` to print a type. You should first make a migration record for the version you are targeting and then lift the `core_type` instance:
```ocaml
(* Assuming rewriter is written against OCaml 4.04 parsetree *)
let migration =
Versions.migrate Versions.ocaml_404 Versions.ocaml_current
let print_core_type fmt typ =
Pprintast.core_type fmt (migration.copy_core_type typ)
```
As for the error message, it contains all information needed to be polymorphic over a whole version of compiler parsetree. Pick what is relevant to your use case :-).
## Features not supported in targeted version
When converting to an earlier version, some features might not be supported. In this case, the migration library will raise an exception. You can find the definition of these cases in `Migrate_parsetree.Def`.
A reasonable error message is provided by default, otherwise you should catch `Migration_error` exceptions after any call to a migration function (either a call to a function from `Migrate_40x_40y` or to a field of `migrate_functions` record). Only backward migrations are partials.
### What kind of guarantees to expect in practice?
The fact that migrations are partial functions can seem too restrictive.
In practice, a problem only happens when an OCaml construction is used that didn't exist in the version the PPX rewriter was implemented with.
This cannot occur when a new version of the compiler is released: existing code that was working before should work immediately after an update, since new features are not yet in use. This use case is the critical one for helping the introduction of a new compiler version (an opam switch should be usable readily after update).
In the future, we might allow rewriting of unsupported features into extensions or attributes for rewriters that opt-in. Rewriting would succeed as long as all extensions disappeared when reaching the compiler (for instance, an OCaml 4.04 file using inline records could be rewritten by a rewriter targeting 4.02; however, a 4.02 files couldn't be rewritten by a 4.04 PPX that introduces inline records).
Please voice your concerns if you have any, so that this use case is better understood.4.02
================================================
FILE: src/vendored-omp/Makefile
================================================
# This file is part of the migrate-parsetree package. It is released under the
# terms of the LGPL 2.1 license (see LICENSE file).
# Copyright 2017 Frédéric Bour
# 2017 Jérémie Dimino
INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),)
.PHONY: all
all:
dune build @install
.PHONY: install
install:
dune install $(INSTALL_ARGS)
.PHONY: uninstall
uninstall:
dune uninstall $(INSTALL_ARGS)
.PHONY: reinstall
reinstall:
$(MAKE) uninstall
$(MAKE) install
.PHONY: test
test:
dune runtest
.PHONY: all-supported-ocaml-versions
all-supported-ocaml-versions:
dune runtest --workspace dune-workspace.dev
.PHONY: cinaps
cinaps:
cinaps -styler ocp-indent -i src/migrate_parsetree_versions.ml*
cinaps -styler ocp-indent -i src/migrate_parsetree_4??_4??.ml*
cinaps -styler ocp-indent -i src/migrate_parsetree.ml
.PHONY: clean
clean:
rm -rf _build *.install
find . -name .merlin -delete
================================================
FILE: src/vendored-omp/README.md
================================================
# OCaml-migrate-parsetree
Convert OCaml parsetrees between different major versions
This library converts between parsetrees of different OCaml versions.
Supported versions are 4.02, 4.03, 4.04, 4.05, 4.06, 4.07, 4.08 and 4.09.
For each version, there is a snapshot of the parsetree and conversion functions
to the next and/or previous version.
## Asts
```ocaml
module Ast_402, Ast_403, Ast_404, Ast_405, Ast_406, Ast_407, Ast_408, Ast_409 : sig
(* These two modules didn't change between compiler versions.
Just share the ones from compiler-libs. *)
module Location = Location
module Longident = Longident
(* Version specific copy of AST *)
module Asttypes
module Parsetree
module Outcometree
(* Other modules that are useful for implementing PPX.
Docstrings and Ast_mapper only contain general definitions
In particular, the internal state used by compiler-libs has been
removed.
Also equalities are lost for abstract types (Docstring.docstring). *)
module Docstrings
module Ast_helper
module Ast_mapper
(* Magic numbers used for marshalling *)
module Config : sig
val ast_impl_magic_number : string
val ast_intf_magic_number : string
end
end
```
These embed copies of AST definitions for each supported OCaml major version.
The AST matching the version of the OCaml toolchain will contain equalities
relating the copy of types to the definitions from compiler-libs. For
instance, when installed with OCaml 4.04.x, `Ast_404.Parsetree` looks
like.
## Migration modules
For each pair of versions `$(n)` and `$(n+1)`, the two modules
`Migrate_parsetree_$(n)_$(n+1)` and `Migrate_parsetree_$(n+1)_$(n)` convert the AST forward and backward.
The forward conversion is total while the backward conversion is partial: when
a feature is not available in a previous version of the parsetree, a
`Migrate_parsetree_def.Migration_error` exception is raised detailing the
failure case.
`Migrate_parsetree_versions` abstract versions of the compiler. Each version is
represented as a module with `OCaml_version` signature. Instances are named
`OCaml_402`, `OCaml_403`, ... `OCaml_current` is an alias to the version of the
current compiler.
The `Convert` functor takes two versions of OCaml and produce conversion
functions.
Finally, the `Migrate_parsetree_ast_io` provides an easy interface for
marshalling/unmarshalling.
## Migrate_parsetree.Driver
The `Migrate_parsetree.Driver` provides an API for ppx rewriters to
register OCaml AST rewriters. Ppx rewriters using this API can be used
as standalone rewriter executable or as part of a _driver_ including
several rewriters.
Using a single driver for several rewritings has the advantage that it
is faster. Especially when using many ppx rewriters, it can speed up
compilation a lot.
If using [Dune](https://github.com/ocaml/dune), you can
consult the dune manual to see how to define and use ppx
rewriters. Dune automatically creates drivers based on
ocaml-migrate-parsetree on demand.
The rest of this section describes how to do things manually or with
[ocamlbuild](https://github.com/ocaml/ocamlbuild).
## Building a custom driver using ocamlfind
To build a custom driver using ocamlfind, simply link all the ppx
rewriter libraries together with the
`ocaml-migrate-parsetree.driver-main` package at the end:
ocamlfind ocamlopt -predicates ppx_driver -o ppx -linkpkg \
-package ppx_sexp_conv -package ppx_bin_prot \
-package ocaml-migrate-parsetree.driver-main
Normally, ocaml-migrate-parsetree based rewriters should be build with
the approriate `-linkall` option on individual libraries. If one is
missing this option, the rewriter might not get linked in. If this is
the case, a workaround is to pass `-linkall` when linking the custom
driver.
The resulting `ppx` program can be used as follow:
- `./ppx file.ml` to print the transformed code
- `ocamlc -pp './ppx --as-pp' ...` to use it as a pre-processor
- `ocamlc -ppx './ppx --as-ppx' ...` to use it as a `-ppx` rewriter
# Development
It started from the work of Alain Frisch in
[ppx\_tools](https://github.com/alainfrisch/ppx_tools).
The library is distributed under LGPL 2.1 and is copyright INRIA.
## Adding a new OCaml version
We use [Cinaps](https://github.com/janestreet/cinaps) to generate boilerplate.
You can install it via opam: `opam install cinaps`.
Add the new version in
[src/cinaps_helpers](https://github.com/ocaml-ppx/ocaml-migrate-parsetree/blob/master/src/cinaps_helpers)
`supported_versions`.
Copy the last `src/ast_xxx.ml` file to `src/ast_<new_version>.ml`,
then go over the file and update each sub-module by replacing its
signature and implementation with the code from the compiler. For the
`Config` sub-module, update the two variables with the values in
`utils/config.mlp` in the compiler source tree.
Once this is done, call:
$ dune exec tools/add_special_comments.exe src/ast_<new_version>.ml
Then diff the `src/ast_xxx.ml` and `src/ast_<new_version>.ml` and go
over the diff to make sure the difference are relevant. The `ast_...`
files require some adjustments which should pop up when you do this
diff. Port the old adjustments to the new file as required.
Add migration functions:
- Manually compile the asts (`ocamlc -c src/ast_{NEW,OLD}.ml -I +compiler-libs -I _build/default/src/vendored-omp/src/.reason_omp.objs/byte -open Reason_omp__`)
- Using `tools/gencopy.exe` (`dune build tools/gencopy.exe`), generate copy code to and from previous version (assuming it is 408):
```
_build/default/tools/gencopy.exe -I . -I src/ -I +compiler-libs -map Ast_409:Ast_408 Ast_409.Parsetree.{expression,expr,pattern,pat,core_type,typ,toplevel_phrase} Ast_409.Outcometree.{out_phrase,out_type_extension} > src/migrate_parsetree_409_408_migrate.ml
_build/default/tools/gencopy.exe -I . -I src/ -I +compiler-libs -map Ast_408:Ast_409 Ast_408.Parsetree.{expression,expr,pattern,pat,core_type,typ,toplevel_phrase} Ast_408.Outcometree.{out_phrase,out_type_extension} > src/migrate_parsetree_408_409_migrate.ml
```
- Fix the generated code by implementing new cases
- The migration functor expects specific names, look at `Migrate_parsetree_versions` interface.
*TODO*: specialize and improve gencopy for these cases
Add mapper lifting functions in the files `migrate_parsetree_NEW_408.ml` and
`migrate_parsetree_408_NEW.ml`:
- include the corresponding `Migrate_parsetree_40x_40y_migrate` module
- define `copy_mapper` function, look at existing `Migrate_parsetree_40x_40y`
for guidance.
At any time, you can expand boilerplate code by running `make cinaps`.
Update build system:
- make sure `make cinaps` reaches a fixed point :)
- `make` should succeed
================================================
FILE: src/vendored-omp/src/ast_408.ml
================================================
(**************************************************************************)
(* *)
(* OCaml Migrate Parsetree *)
(* *)
(* Frédéric Bour, Facebook *)
(* Jérémie Dimino and Leo White, Jane Street Europe *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* Alain Frisch, LexiFi *)
(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 2018 Institut National de Recherche en Informatique et *)
(* en Automatique (INRIA). *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
(* Ast ported on Thu Mar 21 09:50:42 GMT 2019
OCaml was:
commit 55c9ba466362f303eb4d5ed511f6fda142879137 (HEAD -> 4.08, origin/4.08)
Author: Nicolás Ojeda Bär <n.oje.bar@gmail.com>
Date: Tue Mar 19 08:11:02 2019 +0100
Merge pull request #8521 from nojb/fix_unix_tests_408
Actually run all lib-unix tests [4.08]
*)
module Location = Location
module Longident = Longident
module Asttypes = struct
type constant (*IF_CURRENT = Asttypes.constant *) =
Const_int of int
| Const_char of char
| Const_string of string * string option
| Const_float of string
| Const_int32 of int32
| Const_int64 of int64
| Const_nativeint of nativeint
type rec_flag (*IF_CURRENT = Asttypes.rec_flag *) = Nonrecursive | Recursive
type direction_flag (*IF_CURRENT = Asttypes.direction_flag *) = Upto | Downto
(* Order matters, used in polymorphic comparison *)
type private_flag (*IF_CURRENT = Asttypes.private_flag *) = Private | Public
type mutable_flag (*IF_CURRENT = Asttypes.mutable_flag *) = Immutable | Mutable
type virtual_flag (*IF_CURRENT = Asttypes.virtual_flag *) = Virtual | Concrete
type override_flag (*IF_CURRENT = Asttypes.override_flag *) = Override | Fresh
type closed_flag (*IF_CURRENT = Asttypes.closed_flag *) = Closed | Open
type label = string
type arg_label (*IF_CURRENT = Asttypes.arg_label *) =
Nolabel
| Labelled of string (* label:T -> ... *)
| Optional of string (* ?label:T -> ... *)
type 'a loc = 'a Location.loc = {
txt : 'a;
loc : Location.t;
}
type variance (*IF_CURRENT = Asttypes.variance *) =
| Covariant
| Contravariant
| Invariant
end
module Outcometree = struct
(* Module [Outcometree]: results displayed by the toplevel *)
(* These types represent messages that the toplevel displays as normal
results or errors. The real displaying is customisable using the hooks:
[Toploop.print_out_value]
[Toploop.print_out_type]
[Toploop.print_out_sig_item]
[Toploop.print_out_phrase] *)
(** An [out_name] is a string representation of an identifier which can be
rewritten on the fly to avoid name collisions *)
type out_name (*IF_CURRENT = Outcometree.out_name *) = { mutable printed_name: string }
type out_ident (*IF_CURRENT = Outcometree.out_ident *) =
| Oide_apply of out_ident * out_ident
| Oide_dot of out_ident * string
| Oide_ident of out_name
type out_string (*IF_CURRENT = Outcometree.out_string *) =
| Ostr_string
| Ostr_bytes
type out_attribute (*IF_CURRENT = Outcometree.out_attribute *) =
{ oattr_name: string }
type out_value (*IF_CURRENT = Outcometree.out_value *) =
| Oval_array of out_value list
| Oval_char of char
| Oval_constr of out_ident * out_value list
| Oval_ellipsis
| Oval_float of float
| Oval_int of int
| Oval_int32 of int32
| Oval_int64 of int64
| Oval_nativeint of nativeint
| Oval_list of out_value list
| Oval_printer of (Format.formatter -> unit)
| Oval_record of (out_ident * out_value) list
| Oval_string of string * int * out_string (* string, size-to-print, kind *)
| Oval_stuff of string
| Oval_tuple of out_value list
| Oval_variant of string * out_value option
type out_type (*IF_CURRENT = Outcometree.out_type *) =
| Otyp_abstract
| Otyp_open
| Otyp_alias of out_type * string
| Otyp_arrow of string * out_type * out_type
| Otyp_class of bool * out_ident * out_type list
| Otyp_constr of out_ident * out_type list
| Otyp_manifest of out_type * out_type
| Otyp_object of (string * out_type) list * bool option
| Otyp_record of (string * bool * out_type) list
| Otyp_stuff of string
| Otyp_sum of (string * out_type list * out_type option) list
| Otyp_tuple of out_type list
| Otyp_var of bool * string
| Otyp_variant of
bool * out_variant * bool * (string list) option
| Otyp_poly of string list * out_type
| Otyp_module of out_ident * string list * out_type list
| Otyp_attribute of out_type * out_attribute
and out_variant (*IF_CURRENT = Outcometree.out_variant *) =
| Ovar_fields of (string * bool * out_type list) list
| Ovar_typ of out_type
type out_class_type (*IF_CURRENT = Outcometree.out_class_type *) =
| Octy_constr of out_ident * out_type list
| Octy_arrow of string * out_type * out_class_type
| Octy_signature of out_type option * out_class_sig_item list
and out_class_sig_item (*IF_CURRENT = Outcometree.out_class_sig_item *) =
| Ocsg_constraint of out_type * out_type
| Ocsg_method of string * bool * bool * out_type
| Ocsg_value of string * bool * bool * out_type
type out_module_type (*IF_CURRENT = Outcometree.out_module_type *) =
| Omty_abstract
| Omty_functor of string * out_module_type option * out_module_type
| Omty_ident of out_ident
| Omty_signature of out_sig_item list
| Omty_alias of out_ident
and out_sig_item (*IF_CURRENT = Outcometree.out_sig_item *) =
| Osig_class of
bool * string * (string * (bool * bool)) list * out_class_type *
out_rec_status
| Osig_class_type of
bool * string * (string * (bool * bool)) list * out_class_type *
out_rec_status
| Osig_typext of out_extension_constructor * out_ext_status
| Osig_modtype of string * out_module_type
| Osig_module of string * out_module_type * out_rec_status
| Osig_type of out_type_decl * out_rec_status
| Osig_value of out_val_decl
| Osig_ellipsis
and out_type_decl (*IF_CURRENT = Outcometree.out_type_decl *) =
{ otype_name: string;
otype_params: (string * (bool * bool)) list;
otype_type: out_type;
otype_private: Asttypes.private_flag;
otype_immediate: bool;
otype_unboxed: bool;
otype_cstrs: (out_type * out_type) list }
and out_extension_constructor (*IF_CURRENT = Outcometree.out_extension_constructor *) =
{ oext_name: string;
oext_type_name: string;
oext_type_params: string list;
oext_args: out_type list;
oext_ret_type: out_type option;
oext_private: Asttypes.private_flag }
and out_type_extension (*IF_CURRENT = Outcometree.out_type_extension *) =
{ otyext_name: string;
otyext_params: string list;
otyext_constructors: (string * out_type list * out_type option) list;
otyext_private: Asttypes.private_flag }
and out_val_decl (*IF_CURRENT = Outcometree.out_val_decl *) =
{ oval_name: string;
oval_type: out_type;
oval_prims: string list;
oval_attributes: out_attribute list }
and out_rec_status (*IF_CURRENT = Outcometree.out_rec_status *) =
| Orec_not
| Orec_first
| Orec_next
and out_ext_status (*IF_CURRENT = Outcometree.out_ext_status *) =
| Oext_first
| Oext_next
| Oext_exception
type out_phrase (*IF_CURRENT = Outcometree.out_phrase *) =
| Ophr_eval of out_value * out_type
| Ophr_signature of (out_sig_item * out_value option) list
| Ophr_exception of (exn * out_value)
end
================================================
FILE: src/vendored-omp/src/ast_409.ml
================================================
(**************************************************************************)
(* *)
(* OCaml Migrate Parsetree *)
(* *)
(* Frédéric Bour, Facebook *)
(* Jérémie Dimino and Leo White, Jane Street Europe *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* Alain Frisch, LexiFi *)
(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 2018 Institut National de Recherche en Informatique et *)
(* en Automatique (INRIA). *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
module Location = Location
module Longident = Longident
module Asttypes = struct
type constant (*IF_CURRENT = Asttypes.constant *) =
Const_int of int
| Const_char of char
| Const_string of string * string option
| Const_float of string
| Const_int32 of int32
| Const_int64 of int64
| Const_nativeint of nativeint
type rec_flag (*IF_CURRENT = Asttypes.rec_flag *) = Nonrecursive | Recursive
type direction_flag (*IF_CURRENT = Asttypes.direction_flag *) = Upto | Downto
(* Order matters, used in polymorphic comparison *)
type private_flag (*IF_CURRENT = Asttypes.private_flag *) = Private | Public
type mutable_flag (*IF_CURRENT = Asttypes.mutable_flag *) = Immutable | Mutable
type virtual_flag (*IF_CURRENT = Asttypes.virtual_flag *) = Virtual | Concrete
type override_flag (*IF_CURRENT = Asttypes.override_flag *) = Override | Fresh
type closed_flag (*IF_CURRENT = Asttypes.closed_flag *) = Closed | Open
type label = string
type arg_label (*IF_CURRENT = Asttypes.arg_label *) =
Nolabel
| Labelled of string (* label:T -> ... *)
| Optional of string (* ?label:T -> ... *)
type 'a loc = 'a Location.loc = {
txt : 'a;
loc : Location.t;
}
type variance (*IF_CURRENT = Asttypes.variance *) =
| Covariant
| Contravariant
| Invariant
end
module Outcometree = struct
(* Module [Outcometree]: results displayed by the toplevel *)
(* These types represent messages that the toplevel displays as normal
results or errors. The real displaying is customisable using the hooks:
[Toploop.print_out_value]
[Toploop.print_out_type]
[Toploop.print_out_sig_item]
[Toploop.print_out_phrase] *)
(** An [out_name] is a string representation of an identifier which can be
rewritten on the fly to avoid name collisions *)
type out_name (*IF_CURRENT = Outcometree.out_name *) = { mutable printed_name: string }
type out_ident (*IF_CURRENT = Outcometree.out_ident *) =
| Oide_apply of out_ident * out_ident
| Oide_dot of out_ident * string
| Oide_ident of out_name
type out_string (*IF_CURRENT = Outcometree.out_string *) =
| Ostr_string
| Ostr_bytes
type out_attribute (*IF_CURRENT = Outcometree.out_attribute *) =
{ oattr_name: string }
type out_value (*IF_CURRENT = Outcometree.out_value *) =
| Oval_array of out_value list
| Oval_char of char
| Oval_constr of out_ident * out_value list
| Oval_ellipsis
| Oval_float of float
| Oval_int of int
| Oval_int32 of int32
| Oval_int64 of int64
| Oval_nativeint of nativeint
| Oval_list of out_value list
| Oval_printer of (Format.formatter -> unit)
| Oval_record of (out_ident * out_value) list
| Oval_string of string * int * out_string (* string, size-to-print, kind *)
| Oval_stuff of string
| Oval_tuple of out_value list
| Oval_variant of string * out_value option
type out_type (*IF_CURRENT = Outcometree.out_type *) =
| Otyp_abstract
| Otyp_open
| Otyp_alias of out_type * string
| Otyp_arrow of string * out_type * out_type
| Otyp_class of bool * out_ident * out_type list
| Otyp_constr of out_ident * out_type list
| Otyp_manifest of out_type * out_type
| Otyp_object of (string * out_type) list * bool option
| Otyp_record of (string * bool * out_type) list
| Otyp_stuff of string
| Otyp_sum of (string * out_type list * out_type option) list
| Otyp_tuple of out_type list
| Otyp_var of bool * string
| Otyp_variant of
bool * out_variant * bool * (string list) option
| Otyp_poly of string list * out_type
| Otyp_module of out_ident * string list * out_type list
| Otyp_attribute of out_type * out_attribute
and out_variant (*IF_CURRENT = Outcometree.out_variant *) =
| Ovar_fields of (string * bool * out_type list) list
| Ovar_typ of out_type
type out_class_type (*IF_CURRENT = Outcometree.out_class_type *) =
| Octy_constr of out_ident * out_type list
| Octy_arrow of string * out_type * out_class_type
| Octy_signature of out_type option * out_class_sig_item list
and out_class_sig_item (*IF_CURRENT = Outcometree.out_class_sig_item *) =
| Ocsg_constraint of out_type * out_type
| Ocsg_method of string * bool * bool * out_type
| Ocsg_value of string * bool * bool * out_type
type out_module_type (*IF_CURRENT = Outcometree.out_module_type *) =
| Omty_abstract
| Omty_functor of string * out_module_type option * out_module_type
| Omty_ident of out_ident
| Omty_signature of out_sig_item list
| Omty_alias of out_ident
and out_sig_item (*IF_CURRENT = Outcometree.out_sig_item *) =
| Osig_class of
bool * string * (string * (bool * bool)) list * out_class_type *
out_rec_status
| Osig_class_type of
bool * string * (string * (bool * bool)) list * out_class_type *
out_rec_status
| Osig_typext of out_extension_constructor * out_ext_status
| Osig_modtype of string * out_module_type
| Osig_module of string * out_module_type * out_rec_status
| Osig_type of out_type_decl * out_rec_status
| Osig_value of out_val_decl
| Osig_ellipsis
and out_type_decl (*IF_CURRENT = Outcometree.out_type_decl *) =
{ otype_name: string;
otype_params: (string * (bool * bool)) list;
otype_type: out_type;
otype_private: Asttypes.private_flag;
otype_immediate: bool;
otype_unboxed: bool;
otype_cstrs: (out_type * out_type) list }
and out_extension_constructor (*IF_CURRENT = Outcometree.out_extension_constructor *) =
{ oext_name: string;
oext_type_name: string;
oext_type_params: string list;
oext_args: out_type list;
oext_ret_type: out_type option;
oext_private: Asttypes.private_flag }
and out_type_extension (*IF_CURRENT = Outcometree.out_type_extension *) =
{ otyext_name: string;
otyext_params: string list;
otyext_constructors: (string * out_type list * out_type option) list;
otyext_private: Asttypes.private_flag }
and out_val_decl (*IF_CURRENT = Outcometree.out_val_decl *) =
{ oval_name: string;
oval_type: out_type;
oval_prims: string list;
oval_attributes: out_attribute list }
and out_rec_status (*IF_CURRENT = Outcometree.out_rec_status *) =
| Orec_not
| Orec_first
| Orec_next
and out_ext_status (*IF_CURRENT = Outcometree.out_ext_status *) =
| Oext_first
| Oext_next
| Oext_exception
type out_phrase (*IF_CURRENT = Outcometree.out_phrase *) =
| Ophr_eval of out_value * out_type
| Ophr_signature of (out_sig_item * out_value option) list
| Ophr_exception of (exn * out_value)
end
================================================
FILE: src/vendored-omp/src/ast_410.ml
================================================
(**************************************************************************)
(* *)
(* OCaml Migrate Parsetree *)
(* *)
(* Frédéric Bour, Facebook *)
(* Jérémie Dimino and Leo White, Jane Street Europe *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* Alain Frisch, LexiFi *)
(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 2018 Institut National de Recherche en Informatique et *)
(* en Automatique (INRIA). *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
module Location = Location
module Longident = Longident
[@@@warning "-9"]
module Asttypes = struct
type constant (*IF_CURRENT = Asttypes.constant *) =
Const_int of int
| Const_char of char
| Const_string of string * string option
| Const_float of string
| Const_int32 of int32
| Const_int64 of int64
| Const_nativeint of nativeint
type rec_flag (*IF_CURRENT = Asttypes.rec_flag *) = Nonrecursive | Recursive
type direction_flag (*IF_CURRENT = Asttypes.direction_flag *) = Upto | Downto
(* Order matters, used in polymorphic comparison *)
type private_flag (*IF_CURRENT = Asttypes.private_flag *) = Private | Public
type mutable_flag (*IF_CURRENT = Asttypes.mutable_flag *) = Immutable | Mutable
type virtual_flag (*IF_CURRENT = Asttypes.virtual_flag *) = Virtual | Concrete
type override_flag (*IF_CURRENT = Asttypes.override_flag *) = Override | Fresh
type closed_flag (*IF_CURRENT = Asttypes.closed_flag *) = Closed | Open
type label = string
type arg_label (*IF_CURRENT = Asttypes.arg_label *) =
Nolabel
| Labelled of string (* label:T -> ... *)
| Optional of string (* ?label:T -> ... *)
type 'a loc = 'a Location.loc = {
txt : 'a;
loc : Location.t;
}
type variance (*IF_CURRENT = Asttypes.variance *) =
| Covariant
| Contravariant
| Invariant
end
module Type_immediacy = struct
type t (*IF_CURRENT = Type_immediacy.t *) =
| Unknown
| Always
| Always_on_64bits
end
module Outcometree = struct
(* Module [Outcometree]: results displayed by the toplevel *)
(* These types represent messages that the toplevel displays as normal
results or errors. The real displaying is customisable using the hooks:
[Toploop.print_out_value]
[Toploop.print_out_type]
[Toploop.print_out_sig_item]
[Toploop.print_out_phrase] *)
(** An [out_name] is a string representation of an identifier which can be
rewritten on the fly to avoid name collisions *)
type out_name (*IF_CURRENT = Outcometree.out_name *) = { mutable printed_name: string }
type out_ident (*IF_CURRENT = Outcometree.out_ident *) =
| Oide_apply of out_ident * out_ident
| Oide_dot of out_ident * string
| Oide_ident of out_name
type out_string (*IF_CURRENT = Outcometree.out_string *) =
| Ostr_string
| Ostr_bytes
type out_attribute (*IF_CURRENT = Outcometree.out_attribute *) =
{ oattr_name: string }
type out_value (*IF_CURRENT = Outcometree.out_value *) =
| Oval_array of out_value list
| Oval_char of char
| Oval_constr of out_ident * out_value list
| Oval_ellipsis
| Oval_float of float
| Oval_int of int
| Oval_int32 of int32
| Oval_int64 of int64
| Oval_nativeint of nativeint
| Oval_list of out_value list
| Oval_printer of (Format.formatter -> unit)
| Oval_record of (out_ident * out_value) list
| Oval_string of string * int * out_string (* string, size-to-print, kind *)
| Oval_stuff of string
| Oval_tuple of out_value list
| Oval_variant of string * out_value option
type out_type (*IF_CURRENT = Outcometree.out_type *) =
| Otyp_abstract
| Otyp_open
| Otyp_alias of out_type * string
| Otyp_arrow of string * out_type * out_type
| Otyp_class of bool * out_ident * out_type list
| Otyp_constr of out_ident * out_type list
| Otyp_manifest of out_type * out_type
| Otyp_object of (string * out_type) list * bool option
| Otyp_record of (string * bool * out_type) list
| Otyp_stuff of string
| Otyp_sum of (string * out_type list * out_type option) list
| Otyp_tuple of out_type list
| Otyp_var of bool * string
| Otyp_variant of
bool * out_variant * bool * (string list) option
| Otyp_poly of string list * out_type
| Otyp_module of out_ident * string list * out_type list
| Otyp_attribute of out_type * out_attribute
and out_variant (*IF_CURRENT = Outcometree.out_variant *) =
| Ovar_fields of (string * bool * out_type list) list
| Ovar_typ of out_type
type out_class_type (*IF_CURRENT = Outcometree.out_class_type *) =
| Octy_constr of out_ident * out_type list
| Octy_arrow of string * out_type * out_class_type
| Octy_signature of out_type option * out_class_sig_item list
and out_class_sig_item (*IF_CURRENT = Outcometree.out_class_sig_item *) =
| Ocsg_constraint of out_type * out_type
| Ocsg_method of string * bool * bool * out_type
| Ocsg_value of string * bool * bool * out_type
type out_module_type (*IF_CURRENT = Outcometree.out_module_type *) =
| Omty_abstract
| Omty_functor of (string option * out_module_type) option * out_module_type
| Omty_ident of out_ident
| Omty_signature of out_sig_item list
| Omty_alias of out_ident
and out_sig_item (*IF_CURRENT = Outcometree.out_sig_item *) =
| Osig_class of
bool * string * (string * (bool * bool)) list * out_class_type *
out_rec_status
| Osig_class_type of
bool * string * (string * (bool * bool)) list * out_class_type *
out_rec_status
| Osig_typext of out_extension_constructor * out_ext_status
| Osig_modtype of string * out_module_type
| Osig_module of string * out_module_type * out_rec_status
| Osig_type of out_type_decl * out_rec_status
| Osig_value of out_val_decl
| Osig_ellipsis
and out_type_decl (*IF_CURRENT = Outcometree.out_type_decl *) =
{ otype_name: string;
otype_params: (string * (bool * bool)) list;
otype_type: out_type;
otype_private: Asttypes.private_flag;
otype_immediate: Type_immediacy.t;
otype_unboxed: bool;
otype_cstrs: (out_type * out_type) list }
and out_extension_constructor (*IF_CURRENT = Outcometree.out_extension_constructor *) =
{ oext_name: string;
oext_type_name: string;
oext_type_params: string list;
oext_args: out_type list;
oext_ret_type: out_type option;
oext_private: Asttypes.private_flag }
and out_type_extension (*IF_CURRENT = Outcometree.out_type_extension *) =
{ otyext_name: string;
otyext_params: string list;
otyext_constructors: (string * out_type list * out_type option) list;
otyext_private: Asttypes.private_flag }
and out_val_decl (*IF_CURRENT = Outcometree.out_val_decl *) =
{ oval_name: string;
oval_type: out_type;
oval_prims: string list;
oval_attributes: out_attribute list }
and out_rec_status (*IF_CURRENT = Outcometree.out_rec_status *) =
| Orec_not
| Orec_first
| Orec_next
and out_ext_status (*IF_CURRENT = Outcometree.out_ext_status *) =
| Oext_first
| Oext_next
| Oext_exception
type out_phrase (*IF_CURRENT = Outcometree.out_phrase *) =
| Ophr_eval of out_value * out_type
| Ophr_signature of (out_sig_item * out_value option) list
| Ophr_exception of (exn * out_value)
end
================================================
FILE: src/vendored-omp/src/ast_411.ml
================================================
(**************************************************************************)
(* *)
(* OCaml Migrate Parsetree *)
(* *)
(* Frédéric Bour, Facebook *)
(* Jérémie Dimino and Leo White, Jane Street Europe *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* Alain Frisch, LexiFi *)
(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 2018 Institut National de Recherche en Informatique et *)
(* en Automatique (INRIA). *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
module Location = Location
module Longident = Longident
[@@@warning "-9"]
module Asttypes = struct
type constant (*IF_CURRENT = Asttypes.constant *) =
Const_int of int
| Const_char of char
| Const_string of string * Location.t * string option
| Const_float of string
| Const_int32 of int32
| Const_int64 of int64
| Const_nativeint of nativeint
type rec_flag (*IF_CURRENT = Asttypes.rec_flag *) = Nonrecursive | Recursive
type direction_flag (*IF_CURRENT = Asttypes.direction_flag *) = Upto | Downto
(* Order matters, used in polymorphic comparison *)
type private_flag (*IF_CURRENT = Asttypes.private_flag *) = Private | Public
type mutable_flag (*IF_CURRENT = Asttypes.mutable_flag *) = Immutable | Mutable
type virtual_flag (*IF_CURRENT = Asttypes.virtual_flag *) = Virtual | Concrete
type override_flag (*IF_CURRENT = Asttypes.override_flag *) = Override | Fresh
type closed_flag (*IF_CURRENT = Asttypes.closed_flag *) = Closed | Open
type label = string
type arg_label (*IF_CURRENT = Asttypes.arg_label *) =
Nolabel
| Labelled of string (* label:T -> ... *)
| Optional of string (* ?label:T -> ... *)
type 'a loc = 'a Location.loc = {
txt : 'a;
loc : Location.t;
}
type variance (*IF_CURRENT = Asttypes.variance *) =
| Covariant
| Contravariant
| Invariant
end
module Type_immediacy = struct
type t (*IF_CURRENT = Type_immediacy.t *) =
| Unknown
| Always
| Always_on_64bits
end
module Outcometree = struct
(* Module [Outcometree]: results displayed by the toplevel *)
(* These types represent messages that the toplevel displays as normal
results or errors. The real displaying is customisable using the hooks:
[Toploop.print_out_value]
[Toploop.print_out_type]
[Toploop.print_out_sig_item]
[Toploop.print_out_phrase] *)
(** An [out_name] is a string representation of an identifier which can be
rewritten on the fly to avoid name collisions *)
type out_name (*IF_CURRENT = Outcometree.out_name *) = { mutable printed_name: string }
type out_ident (*IF_CURRENT = Outcometree.out_ident *) =
| Oide_apply of out_ident * out_ident
| Oide_dot of out_ident * string
| Oide_ident of out_name
type out_string (*IF_CURRENT = Outcometree.out_string *) =
| Ostr_string
| Ostr_bytes
type out_attribute (*IF_CURRENT = Outcometree.out_attribute *) =
{ oattr_name: string }
type out_value (*IF_CURRENT = Outcometree.out_value *) =
| Oval_array of out_value list
| Oval_char of char
| Oval_constr of out_ident * out_value list
| Oval_ellipsis
| Oval_float of float
| Oval_int of int
| Oval_int32 of int32
| Oval_int64 of int64
| Oval_nativeint of nativeint
| Oval_list of out_value list
| Oval_printer of (Format.formatter -> unit)
| Oval_record of (out_ident * out_value) list
| Oval_string of string * int * out_string (* string, size-to-print, kind *)
| Oval_stuff of string
| Oval_tuple of out_value list
| Oval_variant of string * out_value option
type out_type (*IF_CURRENT = Outcometree.out_type *) =
| Otyp_abstract
| Otyp_open
| Otyp_alias of out_type * string
| Otyp_arrow of string * out_type * out_type
| Otyp_class of bool * out_ident * out_type list
| Otyp_constr of out_ident * out_type list
| Otyp_manifest of out_type * out_type
| Otyp_object of (string * out_type) list * bool option
| Otyp_record of (string * bool * out_type) list
| Otyp_stuff of string
| Otyp_sum of (string * out_type list * out_type option) list
| Otyp_tuple of out_type list
| Otyp_var of bool * string
| Otyp_variant of
bool * out_variant * bool * (string list) option
| Otyp_poly of string list * out_type
| Otyp_module of out_ident * string list * out_type list
| Otyp_attribute of out_type * out_attribute
and out_variant (*IF_CURRENT = Outcometree.out_variant *) =
| Ovar_fields of (string * bool * out_type list) list
| Ovar_typ of out_type
type out_class_type (*IF_CURRENT = Outcometree.out_class_type *) =
| Octy_constr of out_ident * out_type list
| Octy_arrow of string * out_type * out_class_type
| Octy_signature of out_type option * out_class_sig_item list
and out_class_sig_item (*IF_CURRENT = Outcometree.out_class_sig_item *) =
| Ocsg_constraint of out_type * out_type
| Ocsg_method of string * bool * bool * out_type
| Ocsg_value of string * bool * bool * out_type
type out_module_type (*IF_CURRENT = Outcometree.out_module_type *) =
| Omty_abstract
| Omty_functor of (string option * out_module_type) option * out_module_type
| Omty_ident of out_ident
| Omty_signature of out_sig_item list
| Omty_alias of out_ident
and out_sig_item (*IF_CURRENT = Outcometree.out_sig_item *) =
| Osig_class of
bool * string * (string * (bool * bool)) list * out_class_type *
out_rec_status
| Osig_class_type of
bool * string * (string * (bool * bool)) list * out_class_type *
out_rec_status
| Osig_typext of out_extension_constructor * out_ext_status
| Osig_modtype of string * out_module_type
| Osig_module of string * out_module_type * out_rec_status
| Osig_type of out_type_decl * out_rec_status
| Osig_value of out_val_decl
| Osig_ellipsis
and out_type_decl (*IF_CURRENT = Outcometree.out_type_decl *) =
{ otype_name: string;
otype_params: (string * (bool * bool)) list;
otype_type: out_type;
otype_private: Asttypes.private_flag;
otype_immediate: Type_immediacy.t;
otype_unboxed: bool;
otype_cstrs: (out_type * out_type) list }
and out_extension_constructor (*IF_CURRENT = Outcometree.out_extension_constructor *) =
{ oext_name: string;
oext_type_name: string;
oext_type_params: string list;
oext_args: out_type list;
oext_ret_type: out_type option;
oext_private: Asttypes.private_flag }
and out_type_extension (*IF_CURRENT = Outcometree.out_type_extension *) =
{ otyext_name: string;
otyext_params: string list;
otyext_constructors: (string * out_type list * out_type option) list;
otyext_private: Asttypes.private_flag }
and out_val_decl (*IF_CURRENT = Outcometree.out_val_decl *) =
{ oval_name: string;
oval_type: out_type;
oval_prims: string list;
oval_attributes: out_attribute list }
and out_rec_status (*IF_CURRENT = Outcometree.out_rec_status *) =
| Orec_not
| Orec_first
| Orec_next
and out_ext_status (*IF_CURRENT = Outcometree.out_ext_status *) =
| Oext_first
| Oext_next
| Oext_exception
type out_phrase (*IF_CURRENT = Outcometree.out_phrase *) =
| Ophr_eval of out_value * out_type
| Ophr_signature of (out_sig_item * out_value option) list
| Ophr_exception of (exn * out_value)
end
================================================
FILE: src/vendored-omp/src/ast_412.ml
================================================
(**************************************************************************)
(* *)
(* OCaml Migrate Parsetree *)
(* *)
(* Frédéric Bour, Facebook *)
(* Jérémie Dimino and Leo White, Jane Street Europe *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* Alain Frisch, LexiFi *)
(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 2018 Institut National de Recherche en Informatique et *)
(* en Automatique (INRIA). *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
module Asttypes = struct
type constant (*IF_CURRENT = Asttypes.constant *) =
Const_int of int
| Const_char of char
| Const_string of string * Location.t * string option
| Const_float of string
| Const_int32 of int32
| Const_int64 of int64
| Const_nativeint of nativeint
type rec_flag (*IF_CURRENT = Asttypes.rec_flag *) = Nonrecursive | Recursive
type direction_flag (*IF_CURRENT = Asttypes.direction_flag *) = Upto | Downto
(* Order matters, used in polymorphic comparison *)
type private_flag (*IF_CURRENT = Asttypes.private_flag *) = Private | Public
type mutable_flag (*IF_CURRENT = Asttypes.mutable_flag *) = Immutable | Mutable
type virtual_flag (*IF_CURRENT = Asttypes.virtual_flag *) = Virtual | Concrete
type override_flag (*IF_CURRENT = Asttypes.override_flag *) = Override | Fresh
type closed_flag (*IF_CURRENT = Asttypes.closed_flag *) = Closed | Open
type label = string
type arg_label (*IF_CURRENT = Asttypes.arg_label *) =
Nolabel
| Labelled of string (* label:T -> ... *)
| Optional of string (* ?label:T -> ... *)
type 'a loc = 'a Location.loc = {
txt : 'a;
loc : Location.t;
}
type variance (*IF_CURRENT = Asttypes.variance *) =
| Covariant
| Contravariant
| NoVariance
type injectivity (*IF_CURRENT = Asttypes.injectivity *) =
| Injective
| NoInjectivity
end
module Type_immediacy = struct
type t (*IF_CURRENT = Type_immediacy.t *) =
| Unknown
| Always
| Always_on_64bits
end
module Outcometree = struct
(* Module [Outcometree]: results displayed by the toplevel *)
(* These types represent messages that the toplevel displays as normal
results or errors. The real displaying is customisable using the hooks:
[Toploop.print_out_value]
[Toploop.print_out_type]
[Toploop.print_out_sig_item]
[Toploop.print_out_phrase] *)
(** An [out_name] is a string representation of an identifier which can be
rewritten on the fly to avoid name collisions *)
type out_name (*IF_CURRENT = Outcometree.out_name *) = { mutable printed_name: string }
type out_ident (*IF_CURRENT = Outcometree.out_ident *) =
| Oide_apply of out_ident * out_ident
| Oide_dot of out_ident * string
| Oide_ident of out_name
type out_string (*IF_CURRENT = Outcometree.out_string *) =
| Ostr_string
| Ostr_bytes
type out_attribute (*IF_CURRENT = Outcometree.out_attribute *) =
{ oattr_name: string }
type out_value (*IF_CURRENT = Outcometree.out_value *) =
| Oval_array of out_value list
| Oval_char of char
| Oval_constr of out_ident * out_value list
| Oval_ellipsis
| Oval_float of float
| Oval_int of int
| Oval_int32 of int32
| Oval_int64 of int64
| Oval_nativeint of nativeint
| Oval_list of out_value list
| Oval_printer of (Format.formatter -> unit)
| Oval_record of (out_ident * out_value) list
| Oval_string of string * int * out_string (* string, size-to-print, kind *)
| Oval_stuff of string
| Oval_tuple of out_value list
| Oval_variant of string * out_value option
type out_type_param = string * (Asttypes.variance * Asttypes.injectivity)
type out_type (*IF_CURRENT = Outcometree.out_type *) =
| Otyp_abstract
| Otyp_open
| Otyp_alias of out_type * string
| Otyp_arrow of string * out_type * out_type
| Otyp_class of bool * out_ident * out_type list
| Otyp_constr of out_ident * out_type list
| Otyp_manifest of out_type * out_type
| Otyp_object of (string * out_type) list * bool option
| Otyp_record of (string * bool * out_type) list
| Otyp_stuff of string
| Otyp_sum of (string * out_type list * out_type option) list
| Otyp_tuple of out_type list
| Otyp_var of bool * string
| Otyp_variant of
bool * out_variant * bool * (string list) option
| Otyp_poly of string list * out_type
| Otyp_module of out_ident * string list * out_type list
| Otyp_attribute of out_type * out_attribute
and out_variant (*IF_CURRENT = Outcometree.out_variant *) =
| Ovar_fields of (string * bool * out_type list) list
| Ovar_typ of out_type
type out_class_type (*IF_CURRENT = Outcometree.out_class_type *) =
| Octy_constr of out_ident * out_type list
| Octy_arrow of string * out_type * out_class_type
| Octy_signature of out_type option * out_class_sig_item list
and out_class_sig_item (*IF_CURRENT = Outcometree.out_class_sig_item *) =
| Ocsg_constraint of out_type * out_type
| Ocsg_method of string * bool * bool * out_type
| Ocsg_value of string * bool * bool * out_type
type out_module_type (*IF_CURRENT = Outcometree.out_module_type *) =
| Omty_abstract
| Omty_functor of (string option * out_module_type) option * out_module_type
| Omty_ident of out_ident
| Omty_signature of out_sig_item list
| Omty_alias of out_ident
and out_sig_item (*IF_CURRENT = Outcometree.out_sig_item *) =
| Osig_class of
bool * string * out_type_param list * out_class_type *
out_rec_status
| Osig_class_type of
bool * string * out_type_param list * out_class_type *
out_rec_status
| Osig_typext of out_extension_constructor * out_ext_status
| Osig_modtype of string * out_module_type
| Osig_module of string * out_module_type * out_rec_status
| Osig_type of out_type_decl * out_rec_status
| Osig_value of out_val_decl
| Osig_ellipsis
and out_type_decl (*IF_CURRENT = Outcometree.out_type_decl *) =
{ otype_name: string;
otype_params: out_type_param list;
otype_type: out_type;
otype_private: Asttypes.private_flag;
otype_immediate: Type_immediacy.t;
otype_unboxed: bool;
otype_cstrs: (out_type * out_type) list }
and out_extension_constructor (*IF_CURRENT = Outcometree.out_extension_constructor *) =
{ oext_name: string;
oext_type_name: string;
oext_type_params: string list;
oext_args: out_type list;
oext_ret_type: out_type option;
oext_private: Asttypes.private_flag }
and out_type_extension (*IF_CURRENT = Outcometree.out_type_extension *) =
{ otyext_name: string;
otyext_params: string list;
otyext_constructors: (string * out_type list * out_type option) list;
otyext_private: Asttypes.private_flag }
and out_val_decl (*IF_CURRENT = Outcometree.out_val_decl *) =
{ oval_name: string;
oval_type: out_type;
oval_prims: string list;
oval_attributes: out_attribute list }
and out_rec_status (*IF_CURRENT = Outcometree.out_rec_status *) =
| Orec_not
| Orec_first
| Orec_next
and out_ext_status (*IF_CURRENT = Outcometree.out_ext_status *) =
| Oext_first
| Oext_next
| Oext_exception
type out_phrase (*IF_CURRENT = Outcometree.out_phrase *) =
| Ophr_eval of out_value * out_type
| Ophr_signature of (out_sig_item * out_value option) list
| Ophr_exception of (exn * out_value)
end
================================================
FILE: src/vendored-omp/src/ast_413.ml
================================================
(**************************************************************************)
(* *)
(* OCaml Migrate Parsetree *)
(* *)
(* Frédéric Bour, Facebook *)
(* Jérémie Dimino and Leo White, Jane Street Europe *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* Alain Frisch, LexiFi *)
(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 2018 Institut National de Recherche en Informatique et *)
(* en Automatique (INRIA). *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
module Asttypes = struct
type constant (*IF_CURRENT = Asttypes.constant *) =
Const_int of int
| Const_char of char
| Const_string of string * Location.t * string option
| Const_float of string
| Const_int32 of int32
| Const_int64 of int64
| Const_nativeint of nativeint
type rec_flag (*IF_CURRENT = Asttypes.rec_flag *) = Nonrecursive | Recursive
type direction_flag (*IF_CURRENT = Asttypes.direction_flag *) = Upto | Downto
(* Order matters, used in polymorphic comparison *)
type private_flag (*IF_CURRENT = Asttypes.private_flag *) = Private | Public
type mutable_flag (*IF_CURRENT = Asttypes.mutable_flag *) = Immutable | Mutable
type virtual_flag (*IF_CURRENT = Asttypes.virtual_flag *) = Virtual | Concrete
type override_flag (*IF_CURRENT = Asttypes.override_flag *) = Override | Fresh
type closed_flag (*IF_CURRENT = Asttypes.closed_flag *) = Closed | Open
type label = string
type arg_label (*IF_CURRENT = Asttypes.arg_label *) =
Nolabel
| Labelled of string (* label:T -> ... *)
| Optional of string (* ?label:T -> ... *)
type 'a loc = 'a Location.loc = {
txt : 'a;
loc : Location.t;
}
type variance (*IF_CURRENT = Asttypes.variance *) =
| Covariant
| Contravariant
| NoVariance
type injectivity (*IF_CURRENT = Asttypes.injectivity *) =
| Injective
| NoInjectivity
end
module Type_immediacy = struct
type t (*IF_CURRENT = Type_immediacy.t *) =
| Unknown
| Always
| Always_on_64bits
end
module Outcometree = struct
(* Module [Outcometree]: results displayed by the toplevel *)
(* These types represent messages that the toplevel displays as normal
results or errors. The real displaying is customisable using the hooks:
[Toploop.print_out_value]
[Toploop.print_out_type]
[Toploop.print_out_sig_item]
[Toploop.print_out_phrase] *)
(** An [out_name] is a string representation of an identifier which can be
rewritten on the fly to avoid name collisions *)
type out_name (*IF_CURRENT = Outcometree.out_name *) = { mutable printed_name: string }
type out_ident (*IF_CURRENT = Outcometree.out_ident *) =
| Oide_apply of out_ident * out_ident
| Oide_dot of out_ident * string
| Oide_ident of out_name
type out_string (*IF_CURRENT = Outcometree.out_string *) =
| Ostr_string
| Ostr_bytes
type out_attribute (*IF_CURRENT = Outcometree.out_attribute *) =
{ oattr_name: string }
type out_value (*IF_CURRENT = Outcometree.out_value *) =
| Oval_array of out_value list
| Oval_char of char
| Oval_constr of out_ident * out_value list
| Oval_ellipsis
| Oval_float of float
| Oval_int of int
| Oval_int32 of int32
| Oval_int64 of int64
| Oval_nativeint of nativeint
| Oval_list of out_value list
| Oval_printer of (Format.formatter -> unit)
| Oval_record of (out_ident * out_value) list
| Oval_string of string * int * out_string (* string, size-to-print, kind *)
| Oval_stuff of string
| Oval_tuple of out_value list
| Oval_variant of string * out_value option
type out_type_param = string * (Asttypes.variance * Asttypes.injectivity)
type out_type (*IF_CURRENT = Outcometree.out_type *) =
| Otyp_abstract
| Otyp_open
| Otyp_alias of out_type * string
| Otyp_arrow of string * out_type * out_type
| Otyp_class of bool * out_ident * out_type list
| Otyp_constr of out_ident * out_type list
| Otyp_manifest of out_type * out_type
| Otyp_object of (string * out_type) list * bool option
| Otyp_record of (string * bool * out_type) list
| Otyp_stuff of string
| Otyp_sum of (string * out_type list * out_type option) list
| Otyp_tuple of out_type list
| Otyp_var of bool * string
| Otyp_variant of
bool * out_variant * bool * (string list) option
| Otyp_poly of string list * out_type
| Otyp_module of out_ident * (string * out_type) list
| Otyp_attribute of out_type * out_attribute
and out_variant (*IF_CURRENT = Outcometree.out_variant *) =
| Ovar_fields of (string * bool * out_type list) list
| Ovar_typ of out_type
type out_class_type (*IF_CURRENT = Outcometree.out_class_type *) =
| Octy_constr of out_ident * out_type list
| Octy_arrow of string * out_type * out_class_type
| Octy_signature of out_type option * out_class_sig_item list
and out_class_sig_item (*IF_CURRENT = Outcometree.out_class_sig_item *) =
| Ocsg_constraint of out_type * out_type
| Ocsg_method of string * bool * bool * out_type
| Ocsg_value of string * bool * bool * out_type
type out_module_type (*IF_CURRENT = Outcometree.out_module_type *) =
| Omty_abstract
| Omty_functor of (string option * out_module_type) option * out_module_type
| Omty_ident of out_ident
| Omty_signature of out_sig_item list
| Omty_alias of out_ident
and out_sig_item (*IF_CURRENT = Outcometree.out_sig_item *) =
| Osig_class of
bool * string * out_type_param list * out_class_type *
out_rec_status
| Osig_class_type of
bool * string * out_type_param list * out_class_type *
out_rec_status
| Osig_typext of out_extension_constructor * out_ext_status
| Osig_modtype of string * out_module_type
| Osig_module of string * out_module_type * out_rec_status
| Osig_type of out_type_decl * out_rec_status
| Osig_value of out_val_decl
| Osig_ellipsis
and out_type_decl (*IF_CURRENT = Outcometree.out_type_decl *) =
{ otype_name: string;
otype_params: out_type_param list;
otype_type: out_type;
otype_private: Asttypes.private_flag;
otype_immediate: Type_immediacy.t;
otype_unboxed: bool;
otype_cstrs: (out_type * out_type) list }
and out_extension_constructor (*IF_CURRENT = Outcometree.out_extension_constructor *) =
{ oext_name: string;
oext_type_name: string;
oext_type_params: string list;
oext_args: out_type list;
oext_ret_type: out_type option;
oext_private: Asttypes.private_flag }
and out_type_extension (*IF_CURRENT = Outcometree.out_type_extension *) =
{ otyext_name: string;
otyext_params: string list;
otyext_constructors: (string * out_type list * out_type option) list;
otyext_private: Asttypes.private_flag }
and out_val_decl (*IF_CURRENT = Outcometree.out_val_decl *) =
{ oval_name: string;
oval_type: out_type;
oval_prims: string list;
oval_attributes: out_attribute list }
and out_rec_status (*IF_CURRENT = Outcometree.out_rec_status *) =
| Orec_not
| Orec_first
| Orec_next
and out_ext_status (*IF_CURRENT = Outcometree.out_ext_status *) =
| Oext_first
| Oext_next
| Oext_exception
type out_phrase (*IF_CURRENT = Outcometree.out_phrase *) =
| Ophr_eval of out_value * out_type
| Ophr_signature of (out_sig_item * out_value option) list
| Ophr_exception of (exn * out_value)
end
================================================
FILE: src/vendored-omp/src/ast_414.ml
================================================
(**************************************************************************)
(* *)
(* OCaml Migrate Parsetree *)
(* *)
(* Frédéric Bour, Facebook *)
(* Jérémie Dimino and Leo White, Jane Street Europe *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* Alain Frisch, LexiFi *)
(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 2018 Institut National de Recherche en Informatique et *)
(* en Automatique (INRIA). *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
module Asttypes = struct
type constant (*IF_CURRENT = Asttypes.constant *) =
Const_int of int
| Const_char of char
| Const_string of string * Location.t * string option
| Const_float of string
| Const_int32 of int32
| Const_int64 of int64
| Const_nativeint of nativeint
type rec_flag (*IF_CURRENT = Asttypes.rec_flag *) = Nonrecursive | Recursive
type direction_flag (*IF_CURRENT = Asttypes.direction_flag *) = Upto | Downto
(* Order matters, used in polymorphic comparison *)
type private_flag (*IF_CURRENT = Asttypes.private_flag *) = Private | Public
type mutable_flag (*IF_CURRENT = Asttypes.mutable_flag *) = Immutable | Mutable
type virtual_flag (*IF_CURRENT = Asttypes.virtual_flag *) = Virtual | Concrete
type override_flag (*IF_CURRENT = Asttypes.override_flag *) = Override | Fresh
type closed_flag (*IF_CURRENT = Asttypes.closed_flag *) = Closed | Open
type label = string
type arg_label (*IF_CURRENT = Asttypes.arg_label *) =
Nolabel
| Labelled of string (* label:T -> ... *)
| Optional of string (* ?label:T -> ... *)
type 'a loc = 'a Location.loc = {
txt : 'a;
loc : Location.t;
}
type variance (*IF_CURRENT = Asttypes.variance *) =
| Covariant
| Contravariant
| NoVariance
type injectivity (*IF_CURRENT = Asttypes.injectivity *) =
| Injective
| NoInjectivity
end
module Type_immediacy = struct
type t (*IF_CURRENT = Type_immediacy.t *) =
| Unknown
| Always
| Always_on_64bits
end
module Outcometree = struct
(* Module [Outcometree]: results displayed by the toplevel *)
(* These types represent messages that the toplevel displays as normal
results or errors. The real displaying is customisable using the hooks:
[Toploop.print_out_value]
[Toploop.print_out_type]
[Toploop.print_out_sig_item]
[Toploop.print_out_phrase] *)
(** An [out_name] is a string representation of an identifier which can be
rewritten on the fly to avoid name collisions *)
type out_name (*IF_CURRENT = Outcometree.out_name *) = { mutable printed_name: string }
type out_ident (*IF_CURRENT = Outcometree.out_ident *) =
| Oide_apply of out_ident * out_ident
| Oide_dot of out_ident * string
| Oide_ident of out_name
type out_string (*IF_CURRENT = Outcometree.out_string *) =
| Ostr_string
| Ostr_bytes
type out_attribute (*IF_CURRENT = Outcometree.out_attribute *) =
{ oattr_name: string }
type out_value (*IF_CURRENT = Outcometree.out_value *) =
| Oval_array of out_value list
| Oval_char of char
| Oval_constr of out_ident * out_value list
| Oval_ellipsis
| Oval_float of float
| Oval_int of int
| Oval_int32 of int32
| Oval_int64 of int64
| Oval_nativeint of nativeint
| Oval_list of out_value list
| Oval_printer of (Format.formatter -> unit)
| Oval_record of (out_ident * out_value) list
| Oval_string of string * int * out_string (* string, size-to-print, kind *)
| Oval_stuff of string
| Oval_tuple of out_value list
| Oval_variant of string * out_value option
type out_type_param = string * (Asttypes.variance * Asttypes.injectivity)
type out_type (*IF_CURRENT = Outcometree.out_type *) =
| Otyp_abstract
| Otyp_open
| Otyp_alias of out_type * string
| Otyp_arrow of string * out_type * out_type
| Otyp_class of bool * out_ident * out_type list
| Otyp_constr of out_ident * out_type list
| Otyp_manifest of out_type * out_type
| Otyp_object of (string * out_type) list * bool option
| Otyp_record of (string * bool * out_type) list
| Otyp_stuff of string
| Otyp_sum of out_constructor list
| Otyp_tuple of out_type list
| Otyp_var of bool * string
| Otyp_variant of
bool * out_variant * bool * (string list) option
| Otyp_poly of string list * out_type
| Otyp_module of out_ident * (string * out_type) list
| Otyp_attribute of out_type * out_attribute
and out_constructor (*IF_CURRENT = Outcometree.out_constructor *) = {
ocstr_name: string;
ocstr_args: out_type list;
ocstr_return_type: out_type option;
}
and out_variant (*IF_CURRENT = Outcometree.out_variant *) =
| Ovar_fields of (string * bool * out_type list) list
| Ovar_typ of out_type
type out_class_type (*IF_CURRENT = Outcometree.out_class_type *) =
| Octy_constr of out_ident * out_type list
| Octy_arrow of string * out_type * out_class_type
| Octy_signature of out_type option * out_class_sig_item list
and out_class_sig_item (*IF_CURRENT = Outcometree.out_class_sig_item *) =
| Ocsg_constraint of out_type * out_type
| Ocsg_method of string * bool * bool * out_type
| Ocsg_value of string * bool * bool * out_type
type out_module_type (*IF_CURRENT = Outcometree.out_module_type *) =
| Omty_abstract
| Omty_functor of (string option * out_module_type) option * out_module_type
| Omty_ident of out_ident
| Omty_signature of out_sig_item list
| Omty_alias of out_ident
and out_sig_item (*IF_CURRENT = Outcometree.out_sig_item *) =
| Osig_class of
bool * string * out_type_param list * out_class_type *
out_rec_status
| Osig_class_type of
bool * string * out_type_param list * out_class_type *
out_rec_status
| Osig_typext of out_extension_constructor * out_ext_status
| Osig_modtype of string * out_module_type
| Osig_module of string * out_module_type * out_rec_status
| Osig_type of out_type_decl * out_rec_status
| Osig_value of out_val_decl
| Osig_ellipsis
and out_type_decl (*IF_CURRENT = Outcometree.out_type_decl *) =
{ otype_name: string;
otype_params: out_type_param list;
otype_type: out_type;
otype_private: Asttypes.private_flag;
otype_immediate: Type_immediacy.t;
otype_unboxed: bool;
otype_cstrs: (out_type * out_type) list }
and out_extension_constructor (*IF_CURRENT = Outcometree.out_extension_constructor *) =
{ oext_name: string;
oext_type_name: string;
oext_type_params: string list;
oext_args: out_type list;
oext_ret_type: out_type option;
oext_private: Asttypes.private_flag }
and out_type_extension (*IF_CURRENT = Outcometree.out_type_extension *) =
{ otyext_name: string;
otyext_params: string list;
otyext_constructors: out_constructor list;
otyext_private: Asttypes.private_flag }
and out_val_decl (*IF_CURRENT = Outcometree.out_val_decl *) =
{ oval_name: string;
oval_type: out_type;
oval_prims: string list;
oval_attributes: out_attribute list }
and out_rec_status (*IF_CURRENT = Outcometree.out_rec_status *) =
| Orec_not
| Orec_first
| Orec_next
and out_ext_status (*IF_CURRENT = Outcometree.out_ext_status *) =
| Oext_first
| Oext_next
| Oext_exception
type out_phrase (*IF_CURRENT = Outcometree.out_phrase *) =
| Ophr_eval of out_value * out_type
| Ophr_signature of (out_sig_item * out_value option) list
| Ophr_exception of (exn * out_value)
end
================================================
FILE: src/vendored-omp/src/ast_500.ml
================================================
(**************************************************************************)
(* *)
(* OCaml Migrate Parsetree *)
(* *)
(* Frédéric Bour, Facebook *)
(* Jérémie Dimino and Leo White, Jane Street Europe *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* Alain Frisch, LexiFi *)
(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 2018 Institut National de Recherche en Informatique et *)
(* en Automatique (INRIA). *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
module Asttypes = struct
type constant (*IF_CURRENT = Asttypes.constant *) =
Const_int of int
| Const_char of char
| Const_string of string * Location.t * string option
| Const_float of string
| Const_int32 of int32
| Const_int64 of int64
| Const_nativeint of nativeint
type rec_flag (*IF_CURRENT = Asttypes.rec_flag *) = Nonrecursive | Recursive
type direction_flag (*IF_CURRENT = Asttypes.direction_flag *) = Upto | Downto
(* Order matters, used in polymorphic comparison *)
type private_flag (*IF_CURRENT = Asttypes.private_flag *) = Private | Public
type mutable_flag (*IF_CURRENT = Asttypes.mutable_flag *) = Immutable | Mutable
type virtual_flag (*IF_CURRENT = Asttypes.virtual_flag *) = Virtual | Concrete
type override_flag (*IF_CURRENT = Asttypes.override_flag *) = Override | Fresh
type closed_flag (*IF_CURRENT = Asttypes.closed_flag *) = Closed | Open
type label = string
type arg_label (*IF_CURRENT = Asttypes.arg_label *) =
Nolabel
| Labelled of string (* label:T -> ... *)
| Optional of string (* ?label:T -> ... *)
type 'a loc = 'a Location.loc = {
txt : 'a;
loc : Location.t;
}
type variance (*IF_CURRENT = Asttypes.variance *) =
| Covariant
| Contravariant
| NoVariance
type injectivity (*IF_CURRENT = Asttypes.injectivity *) =
| Injective
| NoInjectivity
end
module Type_immediacy = struct
type t (*IF_CURRENT = Type_immediacy.t *) =
| Unknown
| Always
| Always_on_64bits
end
module Outcometree = struct
(* Module [Outcometree]: results displayed by the toplevel *)
(* These types represent messages that the toplevel displays as normal
results or errors. The real displaying is customisable using the hooks:
[Toploop.print_out_value]
[Toploop.print_out_type]
[Toploop.print_out_sig_item]
[Toploop.print_out_phrase] *)
(** An [out_name] is a string representation of an identifier which can be
rewritten on the fly to avoid name collisions *)
type out_name (*IF_CURRENT = Outcometree.out_name *) = { mutable printed_name: string }
type out_ident (*IF_CURRENT = Outcometree.out_ident *) =
| Oide_apply of out_ident * out_ident
| Oide_dot of out_ident * string
| Oide_ident of out_name
type out_string (*IF_CURRENT = Outcometree.out_string *) =
| Ostr_string
| Ostr_bytes
type out_attribute (*IF_CURRENT = Outcometree.out_attribute *) =
{ oattr_name: string }
type out_value (*IF_CURRENT = Outcometree.out_value *) =
| Oval_array of out_value list
| Oval_char of char
| Oval_constr of out_ident * out_value list
| Oval_ellipsis
| Oval_float of float
| Oval_int of int
| Oval_int32 of int32
| Oval_int64 of int64
| Oval_nativeint of nativeint
| Oval_list of out_value list
| Oval_printer of (Format.formatter -> unit)
| Oval_record of (out_ident * out_value) list
| Oval_string of string * int * out_string (* string, size-to-print, kind *)
| Oval_stuff of string
| Oval_tuple of out_value list
| Oval_variant of string * out_value option
type out_type_param = string * (Asttypes.variance * Asttypes.injectivity)
type out_type (*IF_CURRENT = Outcometree.out_type *) =
| Otyp_abstract
| Otyp_open
| Otyp_alias of out_type * string
| Otyp_arrow of string * out_type * out_type
| Otyp_class of bool * out_ident * out_type list
| Otyp_constr of out_ident * out_type list
| Otyp_manifest of out_type * out_type
| Otyp_object of (string * out_type) list * bool option
| Otyp_record of (string * bool * out_type) list
| Otyp_stuff of string
| Otyp_sum of out_constructor list
| Otyp_tuple of out_type list
| Otyp_var of bool * string
| Otyp_variant of
bool * out_variant * bool * (string list) option
| Otyp_poly of string list * out_type
| Otyp_module of out_ident * (string * out_type) list
| Otyp_attribute of out_type * out_attribute
and out_constructor (*IF_CURRENT = Outcometree.out_constructor *) = {
ocstr_name: string;
ocstr_args: out_type list;
ocstr_return_type: out_type option;
}
and out_variant (*IF_CURRENT = Outcometree.out_variant *) =
| Ovar_fields of (string * bool * out_type list) list
| Ovar_typ of out_type
type out_class_type (*IF_CURRENT = Outcometree.out_class_type *) =
| Octy_constr of out_ident * out_type list
| Octy_arrow of string * out_type * out_class_type
| Octy_signature of out_type option * out_class_sig_item list
and out_class_sig_item (*IF_CURRENT = Outcometree.out_class_sig_item *) =
| Ocsg_constraint of out_type * out_type
| Ocsg_method of string * bool * bool * out_type
| Ocsg_value of string * bool * bool * out_type
type out_module_type (*IF_CURRENT = Outcometree.out_module_type *) =
| Omty_abstract
| Omty_functor of (string option * out_module_type) option * out_module_type
| Omty_ident of out_ident
| Omty_signature of out_sig_item list
| Omty_alias of out_ident
and out_sig_item (*IF_CURRENT = Outcometree.out_sig_item *) =
| Osig_class of
bool * string * out_type_param list * out_class_type *
out_rec_status
| Osig_class_type of
bool * string * out_type_param list * out_class_type *
out_rec_status
| Osig_typext of out_extension_constructor * out_ext_status
| Osig_modtype of string * out_module_type
| Osig_module of string * out_module_type * out_rec_status
| Osig_type of out_type_decl * out_rec_status
| Osig_value of out_val_decl
| Osig_ellipsis
and out_type_decl (*IF_CURRENT = Outcometree.out_type_decl *) =
{ otype_name: string;
otype_params: out_type_param list;
otype_type: out_type;
otype_private: Asttypes.private_flag;
otype_immediate: Type_immediacy.t;
otype_unboxed: bool;
otype_cstrs: (out_type * out_type) list }
and out_extension_constructor (*IF_CURRENT = Outcometree.out_extension_constructor *) =
{ oext_name: string;
oext_type_name: string;
oext_type_params: string list;
oext_args: out_type list;
oext_ret_type: out_type option;
oext_private: Asttypes.private_flag }
and out_type_extension (*IF_CURRENT = Outcometree.out_type_extension *) =
{ otyext_name: string;
otyext_params: string list;
otyext_constructors: out_constructor list;
otyext_private: Asttypes.private_flag }
and out_val_decl (*IF_CURRENT = Outcometree.out_val_decl *) =
{ oval_name: string;
oval_type: out_type;
oval_prims: string list;
oval_attributes: out_attribute list }
and out_rec_status (*IF_CURRENT = Outcometree.out_rec_status *) =
| Orec_not
| Orec_first
| Orec_next
and out_ext_status (*IF_CURRENT = Outcometree.out_ext_status *) =
| Oext_first
| Oext_next
| Oext_exception
type out_phrase (*IF_CURRENT = Outcometree.out_phrase *) =
| Ophr_eval of out_value * out_type
| Ophr_signature of (out_sig_item * out_value option) list
| Ophr_exception of (exn * out_value)
end
================================================
FILE: src/vendored-omp/src/ast_51.ml
================================================
module Asttypes = struct
type constant (*IF_CURRENT = Asttypes.constant *) =
Const_int of int
| Const_char of char
| Const_string of string * Location.t * string option
| Const_float of string
| Const_int32 of int32
| Const_int64 of int64
| Const_nativeint of nativeint
type rec_flag (*IF_CURRENT = Asttypes.rec_flag *) = Nonrecursive | Recursive
type direction_flag (*IF_CURRENT = Asttypes.direction_flag *) = Upto | Downto
(* Order matters, used in polymorphic comparison *)
type private_flag (*IF_CURRENT = Asttypes.private_flag *) = Private | Public
type mutable_flag (*IF_CURRENT = Asttypes.mutable_flag *) = Immutable | Mutable
type virtual_flag (*IF_CURRENT = Asttypes.virtual_flag *) = Virtual | Concrete
type override_flag (*IF_CURRENT = Asttypes.override_flag *) = Override | Fresh
type closed_flag (*IF_CURRENT = Asttypes.closed_flag *) = Closed | Open
type label = string
type arg_label (*IF_CURRENT = Asttypes.arg_label *) =
Nolabel
| Labelled of string (** [label:T -> ...] *)
| Optional of string (** [?label:T -> ...] *)
type 'a loc = 'a Location.loc = {
txt : 'a;
loc : Location.t;
}
type variance (*IF_CURRENT = Asttypes.variance *) =
| Covariant
| Contravariant
| NoVariance
type injectivity (*IF_CURRENT = Asttypes.injectivity *) =
| Injective
| NoInjectivity
end
module Type_immediacy = struct
type t (*IF_CURRENT = Type_immediacy.t *) =
| Unknown
| Always
| Always_on_64bits
end
module Outcometree = struct
(* Module [Outcometree]: results displayed by the toplevel *)
(* These types represent messages that the toplevel displays as normal
results or errors. The real displaying is customisable using the hooks:
[Toploop.print_out_value]
[Toploop.print_out_type]
[Toploop.print_out_sig_item]
[Toploop.print_out_phrase] *)
(** An [out_name] is a string representation of an identifier which can be
rewritten on the fly to avoid name collisions *)
type out_name (*IF_CURRENT = Outcometree.out_name *) = { mutable printed_name: string }
type out_ident (*IF_CURRENT = Outcometree.out_ident *) =
| Oide_apply of out_ident * out_ident
| Oide_dot of out_ident * string
| Oide_ident of out_name
type out_string (*IF_CURRENT = Outcometree.out_string *) =
| Ostr_string
| Ostr_bytes
type out_attribute (*IF_CURRENT = Outcometree.out_attribute *) =
{ oattr_name: string }
type out_value (*IF_CURRENT = Outcometree.out_value *) =
| Oval_array of out_value list
| Oval_char of char
| Oval_constr of out_ident * out_value list
| Oval_ellipsis
| Oval_float of float
| Oval_int of int
| Oval_int32 of int32
| Oval_int64 of int64
| Oval_nativeint of nativeint
| Oval_list of out_value list
| Oval_printer of (Format.formatter -> unit)
| Oval_record of (out_ident * out_value) list
| Oval_string of string * int * out_string (* string, size-to-print, kind *)
| Oval_stuff of string
| Oval_tuple of out_value list
| Oval_variant of string * out_value option
type out_type_param = string * (Asttypes.variance * Asttypes.injectivity)
type out_type (*IF_CURRENT = Outcometree.out_type *) =
| Otyp_abstract
| Otyp_open
| Otyp_alias of {non_gen:bool; aliased:out_type; alias:string}
| Otyp_arrow of string * out_type * out_type
| Otyp_class of out_ident * out_type list
| Otyp_constr of out_ident * out_type list
| Otyp_manifest of out_type * out_type
| Otyp_object of { fields: (string * out_type) list; open_row:bool}
| Otyp_record of (string * bool * out_type) list
| Otyp_stuff of string
| Otyp_sum of out_constructor list
| Otyp_tuple of out_type list
| Otyp_var of bool * string
| Otyp_variant of out_variant * bool * (string list) option
| Otyp_poly of string list * out_type
| Otyp_module of out_ident * (string * out_type) list
| Otyp_attribute of out_type * out_attribute
and out_constructor (*IF_CURRENT = Outcometree.out_constructor *) = {
ocstr_name: string;
ocstr_args: out_type list;
ocstr_return_type: out_type option;
}
and out_variant (*IF_CURRENT = Outcometree.out_variant *) =
| Ovar_fields of (string * bool * out_type list) list
| Ovar_typ of out_type
type out_class_type (*IF_CURRENT = Outcometree.out_class_type *) =
| Octy_constr of out_ident * out_type list
| Octy_arrow of string * out_type * out_class_type
| Octy_signature of out_type option * out_class_sig_item list
and out_class_sig_item (*IF_CURRENT = Outcometree.out_class_sig_item *) =
| Ocsg_constraint of out_type * out_type
| Ocsg_method of string * bool * bool * out_type
| Ocsg_value of string * bool * bool * out_type
type out_module_type (*IF_CURRENT = Outcometree.out_module_type *) =
| Omty_abstract
| Omty_functor of (string option * out_module_type) option * out_module_type
| Omty_ident of out_ident
| Omty_signature of out_sig_item list
| Omty_alias of out_ident
and out_sig_item (*IF_CURRENT = Outcometree.out_sig_item *) =
| Osig_class of
bool * string * out_type_param list * out_class_type *
out_rec_status
| Osig_class_type of
bool * string * out_type_param list * out_class_type *
out_rec_status
| Osig_typext of out_extension_constructor * out_ext_status
| Osig_modtype of string * out_module_type
| Osig_module of string * out_module_type * out_rec_status
| Osig_type of out_type_decl * out_rec_status
| Osig_value of out_val_decl
| Osig_ellipsis
and out_type_decl (*IF_CURRENT = Outcometree.out_type_decl *) =
{ otype_name: string;
otype_params: out_type_param list;
otype_type: out_type;
otype_private: Asttypes.private_flag;
otype_immediate: Type_immediacy.t;
otype_unboxed: bool;
otype_cstrs: (out_type * out_type) list }
and out_extension_constructor (*IF_CURRENT = Outcometree.out_extension_constructor *) =
{ oext_name: string;
oext_type_name: string;
oext_type_params: string list;
oext_args: out_type list;
oext_ret_type: out_type option;
oext_private: Asttypes.private_flag }
and out_type_extension (*IF_CURRENT = Outcometree.out_type_extension *) =
{ otyext_name: string;
otyext_params: string list;
otyext_constructors: out_constructor list;
otyext_private: Asttypes.private_flag }
and out_val_decl (*IF_CURRENT = Outcometree.out_val_decl *) =
{ oval_name: string;
oval_type: out_type;
oval_prims: string list;
oval_attributes: out_attribute list }
and out_rec_status (*IF_CURRENT = Outcometree.out_rec_status *) =
| Orec_not
| Orec_first
| Orec_next
and out_ext_status (*IF_CURRENT = Outcometree.out_ext_status *) =
| Oext_first
| Oext_next
| Oext_exception
type out_phrase (*IF_CURRENT = Outcometree.out_phrase *) =
| Ophr_eval of out_value * out_type
| Ophr_signature of (out_sig_item * out_value option) list
| Ophr_exception of (exn * out_value)
end
================================================
FILE: src/vendored-omp/src/ast_52.ml
================================================
module Asttypes = struct
type constant (*IF_CURRENT = Asttypes.constant *) =
Const_int of int
| Const_char of char
| Const_string of string * Location.t * string option
| Const_float of string
| Const_int32 of int32
| Const_int64 of int64
| Const_nativeint of nativeint
type rec_flag (*IF_CURRENT = Asttypes.rec_flag *) = Nonrecursive | Recursive
type direction_flag (*IF_CURRENT = Asttypes.direction_flag *) = Upto | Downto
(* Order matters, used in polymorphic comparison *)
type private_flag (*IF_CURRENT = Asttypes.private_flag *) = Private | Public
type mutable_flag (*IF_CURRENT = Asttypes.mutable_flag *) = Immutable | Mutable
type virtual_flag (*IF_CURRENT = Asttypes.virtual_flag *) = Virtual | Concrete
type override_flag (*IF_CURRENT = Asttypes.override_flag *) = Override | Fresh
type closed_flag (*IF_CURRENT = Asttypes.closed_flag *) = Closed | Open
type label = string
type arg_label (*IF_CURRENT = Asttypes.arg_label *) =
Nolabel
| Labelled of string (** [label:T -> ...] *)
| Optional of string (** [?label:T -> ...] *)
type 'a loc = 'a Location.loc = {
txt : 'a;
loc : Location.t;
}
type variance (*IF_CURRENT = Asttypes.variance *) =
| Covariant
| Contravariant
| NoVariance
type injectivity (*IF_CURRENT = Asttypes.injectivity *) =
| Injective
| NoInjectivity
end
module Type_immediacy = struct
type t (*IF_CURRENT = Type_immediacy.t *) =
| Unknown
| Always
| Always_on_64bits
end
module Outcometree = struct
(* Module [Outcometree]: results displayed by the toplevel *)
(* These types represent messages that the toplevel displays as normal
results or errors. The real displaying is customisable using the hooks:
[Toploop.print_out_value]
[Toploop.print_out_type]
[Toploop.print_out_sig_item]
[Toploop.print_out_phrase] *)
(** An [out_name] is a string representation of an identifier which can be
rewritten on the fly to avoid name collisions *)
type out_name (*IF_CURRENT = Outcometree.out_name *) = { mutable printed_name: string }
type out_ident (*IF_CURRENT = Outcometree.out_ident *) =
| Oide_apply of out_ident * out_ident
| Oide_dot of out_ident * string
| Oide_ident of out_name
type out_string (*IF_CURRENT = Outcometree.out_string *) =
| Ostr_string
| Ostr_bytes
type out_attribute (*IF_CURRENT = Outcometree.out_attribute *) =
{ oattr_name: string }
type out_value (*IF_CURRENT = Outcometree.out_value *) =
| Oval_array of out_value list
| Oval_char of char
| Oval_constr of out_ident * out_value list
| Oval_ellipsis
| Oval_float of float
| Oval_int of int
| Oval_int32 of int32
| Oval_int64 of int64
| Oval_nativeint of nativeint
| Oval_list of out_value list
| Oval_printer of (Format.formatter -> unit)
| Oval_record of (out_ident * out_value) list
| Oval_string of string * int * out_string (* string, size-to-print, kind *)
| Oval_stuff of string
| Oval_tuple of out_value list
| Oval_variant of string * out_value option
| Oval_lazy of out_value
type out_type_param (*IF_CURRENT = Outcometree.out_type_param *) = {
ot_non_gen: bool;
ot_name: string;
ot_variance: Asttypes.variance * Asttypes.injectivity
}
type out_type (*IF_CURRENT = Outcometree.out_type *) =
| Otyp_abstract
| Otyp_open
| Otyp_alias of {non_gen:bool; aliased:out_type; alias:string}
| Otyp_arrow of Asttypes.arg_label * out_type * out_type
| Otyp_class of out_ident * out_type list
| Otyp_constr of out_ident * out_type list
| Otyp_manifest of out_type * out_type
| Otyp_object of { fields: (string * out_type) list; open_row:bool}
| Otyp_record of (string * bool * out_type) list
| Otyp_stuff of string
| Otyp_sum of out_constructor list
| Otyp_tuple of out_type list
| Otyp_var of bool * string
| Otyp_variant of out_variant * bool * (string list) option
| Otyp_poly of string list * out_type
| Otyp_module of out_ident * (string * out_type) list
| Otyp_attribute of out_type * out_attribute
and out_constructor (*IF_CURRENT = Outcometree.out_constructor *) = {
ocstr_name: string;
ocstr_args: out_type list;
ocstr_return_type: out_type option;
}
and out_variant (*IF_CURRENT = Outcometree.out_variant *) =
| Ovar_fields of (string * bool * out_type list) list
| Ovar_typ of out_type
type out_class_type (*IF_CURRENT = Outcometree.out_class_type *) =
| Octy_constr of out_ident * out_type list
| Octy_arrow of Asttypes.arg_label * out_type * out_class_type
| Octy_signature of out_type option * out_class_sig_item list
and out_class_sig_item (*IF_CURRENT = Outcometree.out_class_sig_item *) =
| Ocsg_constraint of out_type * out_type
| Ocsg_method of string * bool * bool * out_type
| Ocsg_value of string * bool * bool * out_type
type out_module_type (*IF_CURRENT = Outcometree.out_module_type *) =
| Omty_abstract
| Omty_functor of (string option * out_module_type) option * out_module_type
| Omty_ident of out_ident
| Omty_signature of out_sig_item list
| Omty_alias of out_ident
and out_sig_item (*IF_CURRENT = Outcometree.out_sig_item *) =
| Osig_class of
bool * string * out_type_param list * out_class_type *
out_rec_status
| Osig_class_type of
bool * string * out_type_param list * out_class_type *
out_rec_status
| Osig_typext of out_extension_constructor * out_ext_status
| Osig_modtype of string * out_module_type
| Osig_module of string * out_module_type * out_rec_status
| Osig_type of out_type_decl * out_rec_status
| Osig_value of out_val_decl
| Osig_ellipsis
and out_type_decl (*IF_CURRENT = Outcometree.out_type_decl *) =
{ otype_name: string;
otype_params: out_type_param list;
otype_type: out_type;
otype_private: Asttypes.private_flag;
otype_immediate: Type_immediacy.t;
otype_unboxed: bool;
otype_cstrs: (out_type * out_type) list }
and out_extension_constructor (*IF_CURRENT = Outcometree.out_extension_constructor *) =
{ oext_name: string;
oext_type_name: string;
oext_type_params: string list;
oext_args: out_type list;
oext_ret_type: out_type option;
oext_private: Asttypes.private_flag }
and out_type_extension (*IF_CURRENT = Outcometree.out_type_extension *) =
{ otyext_name: string;
otyext_params: string list;
otyext_constructors: out_constructor list;
otyext_private: Asttypes.private_flag }
and out_val_decl (*IF_CURRENT = Outcometree.out_val_decl *) =
{ oval_name: string;
oval_type: out_type;
oval_prims: string list;
oval_attributes: out_attribute list }
and out_rec_status (*IF_CURRENT = Outcometree.out_rec_status *) =
| Orec_not
| Orec_first
| Orec_next
and out_ext_status (*IF_CURRENT = Outcometree.out_ext_status *) =
| Oext_first
| Oext_next
| Oext_exception
type out_phrase (*IF_CURRENT = Outcometree.out_phrase *) =
| Ophr_eval of out_value * out_type
| Ophr_signature of (out_sig_item * out_value option) list
| Ophr_exception of (exn * out_value)
end
================================================
FILE: src/vendored-omp/src/ast_53.ml
================================================
module Asttypes = struct
type constant (*IF_CURRENT = Asttypes.constant *) =
Const_int of int
| Const_char of char
| Const_string of string * Location.t * string option
| Const_float of string
| Const_int32 of int32
| Const_int64 of int64
| Const_nativeint of nativeint
type rec_flag (*IF_CURRENT = Asttypes.rec_flag *) = Nonrecursive | Recursive
type direction_flag (*IF_CURRENT = Asttypes.direction_flag *) = Upto | Downto
(* Order matters, used in polymorphic comparison *)
type private_flag (*IF_CURRENT = Asttypes.private_flag *) = Private | Public
type mutable_flag (*IF_CURRENT = Asttypes.mutable_flag *) = Immutable | Mutable
type virtual_flag (*IF_CURRENT = Asttypes.virtual_flag *) = Virtual | Concrete
type override_flag (*IF_CURRENT = Asttypes.override_flag *) = Override | Fresh
type closed_flag (*IF_CURRENT = Asttypes.closed_flag *) = Closed | Open
type label = string
type arg_label (*IF_CURRENT = Asttypes.arg_label *) =
Nolabel
| Labelled of string (** [label:T -> ...] *)
| Optional of string (** [?label:T -> ...] *)
type 'a loc = 'a Location.loc = {
txt : 'a;
loc : Location.t;
}
type variance (*IF_CURRENT = Asttypes.variance *) =
| Covariant
| Contravariant
| NoVariance
type injectivity (*IF_CURRENT = Asttypes.injectivity *) =
| Injective
| NoInjectivity
end
module Type_immediacy = struct
type t (*IF_CURRENT = Type_immediacy.t *) =
| Unknown
| Always
| Always_on_64bits
end
module Outcometree = struct
(* Module [Outcometree]: results displayed by the toplevel *)
(* These types represent messages that the toplevel displays as normal
results or errors. The real displaying is customisable using the hooks:
[Toploop.print_out_value]
[Toploop.print_out_type]
[Toploop.print_out_sig_item]
[Toploop.print_out_phrase] *)
(** An [out_name] is a string representation of an identifier which can be
rewritten on the fly to avoid name collisions *)
type out_name (*IF_CURRENT = Outcometree.out_name *) = { mutable printed_name: string }
type out_ident (*IF_CURRENT = Outcometree.out_ident *) =
| Oide_apply of out_ident * out_ident
| Oide_dot of out_ident * string
| Oide_ident of out_name
type out_string (*IF_CURRENT = Outcometree.out_string *) =
| Ostr_string
| Ostr_bytes
type out_attribute (*IF_CURRENT = Outcometree.out_attribute *) =
{ oattr_name: string }
type out_value (*IF_CURRENT = Outcometree.out_value *) =
| Oval_array of out_value list
| Oval_char of char
| Oval_constr of out_ident * out_value list
| Oval_ellipsis
| Oval_float of float
| Oval_int of int
| Oval_int32 of int32
| Oval_int64 of int64
| Oval_nativeint of nativeint
| Oval_list of out_value list
| Oval_printer of (Caml_format_doc.formatter -> unit)
| Oval_record of (out_ident * out_value) list
| Oval_string of string * int * out_string (* string, size-to-print, kind *)
| Oval_stuff of string
| Oval_tuple of out_value list
| Oval_variant of string * out_value option
| Oval_lazy of out_value
type out_type_param (*IF_CURRENT = Outcometree.out_type_param *) = {
ot_non_gen: bool;
ot_name: string;
ot_variance: Asttypes.variance * Asttypes.injectivity
}
type out_type (*IF_CURRENT = Outcometree.out_type *) =
| Otyp_abstract
| Otyp_open
| Otyp_alias of {non_gen:bool; aliased:out_type; alias:string}
| Otyp_arrow of Asttypes.arg_label * out_type * out_type
| Otyp_class of out_ident * out_type list
| Otyp_constr of out_ident * out_type list
| Otyp_manifest of out_type * out_type
| Otyp_object of { fields: (string * out_type) list; open_row:bool}
| Otyp_record of out_label list
| Otyp_stuff of string
| Otyp_sum of out_constructor list
| Otyp_tuple of out_type list
| Otyp_var of bool * string
| Otyp_variant of out_variant * bool * (string list) option
| Otyp_poly of string list * out_type
| Otyp_module of out_ident * (string * out_type) list
| Otyp_attribute of out_type * out_attribute
and out_label (*IF_CURRENT = Outcometree.out_label *) = {
olab_name: string;
olab_mut: Asttypes.mutable_flag;
olab_type: out_type;
}
and out_constructor (*IF_CURRENT = Outcometree.out_constructor *) = {
ocstr_name: string;
ocstr_args: out_type list;
ocstr_return_type: out_type option;
}
and out_variant (*IF_CURRENT = Outcometree.out_variant *) =
| Ovar_fields of (string * bool * out_type list) list
| Ovar_typ of out_type
type out_class_type (*IF_CURRENT = Outcometree.out_class_type *) =
| Octy_constr of out_ident * out_type list
| Octy_arrow of Asttypes.arg_label * out_type * out_class_type
| Octy_signature of out_type option * out_class_sig_item list
and out_class_sig_item (*IF_CURRENT = Outcometree.out_class_sig_item *) =
| Ocsg_constraint of out_type * out_type
| Ocsg_method of string * bool * bool * out_type
| Ocsg_value of string * bool * bool * out_type
type out_module_type (*IF_CURRENT = Outcometree.out_module_type *) =
| Omty_abstract
| Omty_functor of (string option * out_module_type) option * out_module_type
| Omty_ident of out_ident
| Omty_signature of out_sig_item list
| Omty_alias of out_ident
and out_sig_item (*IF_CURRENT = Outcometree.out_sig_item *) =
| Osig_class of
bool * string * out_type_param list * out_class_type *
out_rec_status
| Osig_class_type of
bool * string * out_type_param list * out_class_type *
out_rec_status
| Osig_typext of out_extension_constructor * out_ext_status
| Osig_modtype of string * out_module_type
| Osig_module of string * out_module_type * out_rec_status
| Osig_type of out_type_decl * out_rec_status
| Osig_value of out_val_decl
| Osig_ellipsis
and out_type_decl (*IF_CURRENT = Outcometree.out_type_decl *) =
{ otype_name: string;
otype_params: out_type_param list;
otype_type: out_type;
otype_private: Asttypes.private_flag;
otype_immediate: Type_immediacy.t;
otype_unboxed: bool;
otype_cstrs: (out_type * out_type) list }
and out_extension_constructor (*IF_CURRENT = Outcometree.out_extension_constructor *) =
{ oext_name: string;
oext_type_name: string;
oext_type_params: string list;
oext_args: out_type list;
oext_ret_type: out_type option;
oext_private: Asttypes.private_flag }
and out_type_extension (*IF_CURRENT = Outcometree.out_type_extension *) =
{ otyext_name: string;
otyext_params: string list;
otyext_constructors: out_constructor list;
otyext_private: Asttypes.private_flag }
and out_val_decl (*IF_CURRENT = Outcometree.out_val_decl *) =
{ oval_name: string;
oval_type: out_type;
oval_prims: string list;
oval_attributes: out_attribute list }
and out_rec_status (*IF_CURRENT = Outcometree.out_rec_status *) =
| Orec_not
| Orec_first
| Orec_next
and out_ext_status (*IF_CURRENT = Outcometree.out_ext_status *) =
| Oext_first
| Oext_next
| Oext_exception
type out_phrase (*IF_CURRENT = Outcometree.out_phrase *) =
| Ophr_eval of out_value * out_type
| Ophr_signature of (out_sig_item * out_value option) list
| Ophr_exception of (exn * out_value)
end
================================================
FILE: src/vendored-omp/src/ast_54.ml
================================================
module Asttypes = struct
type constant (*IF_CURRENT = Asttypes.constant *) =
Const_int of int
| Const_char of char
| Const_string of string * Location.t * string option
| Const_float of string
| Const_int32 of int32
| Const_int64 of int64
| Const_nativeint of nativeint
type rec_flag (*IF_CURRENT = Asttypes.rec_flag *) = Nonrecursive | Recursive
type direction_flag (*IF_CURRENT = Asttypes.direction_flag *) = Upto | Downto
(* Order matters, used in polymorphic comparison *)
type private_flag (*IF_CURRENT = Asttypes.private_flag *) = Private | Public
type mutable_flag (*IF_CURRENT = Asttypes.mutable_flag *) = Immutable | Mutable
type atomic_flag (*IF_CURRENT = Asttypes.atomic_flag *) = Nonatomic | Atomic
type virtual_flag (*IF_CURRENT = Asttypes.virtual_flag *) = Virtual | Concrete
type override_flag (*IF_CURRENT = Asttypes.override_flag *) = Override | Fresh
type closed_flag (*IF_CURRENT = Asttypes.closed_flag *) = Closed | Open
type label = string
type arg_label (*IF_CURRENT = Asttypes.arg_label *) =
Nolabel
| Labelled of string (** [label:T -> ...] *)
| Optional of string (** [?label:T -> ...] *)
type 'a loc = 'a Location.loc = {
txt : 'a;
loc : Location.t;
}
type variance (*IF_CURRENT = Asttypes.variance *) =
| Covariant
| Contravariant
| NoVariance
| Bivariant
type injectivity (*IF_CURRENT = Asttypes.injectivity *) =
| Injective
| NoInjectivity
end
module Type_immediacy = struct
type t (*IF_CURRENT = Type_immediacy.t *) =
| Unknown
| Always
| Always_on_64bits
end
module Outcometree = struct
(* Module [Outcometree]: results displayed by the toplevel *)
(* These types represent messages that the toplevel displays as normal
results or errors. The real displaying is customisable using the hooks:
[Toploop.print_out_value]
[Toploop.print_out_type]
[Toploop.print_out_sig_item]
[Toploop.print_out_phrase] *)
(** An [out_name] is a string representation of an identifier which can be
rewritten on the fly to avoid name collisions *)
type out_name (*IF_CURRENT = Outcometree.out_name *) = { mutable printed_name: string }
type out_ident (*IF_CURRENT = Outcometree.out_ident *) =
| Oide_apply of out_ident * out_ident
| Oide_dot of out_ident * string
| Oide_ident of out_name
type out_string (*IF_CURRENT = Outcometree.out_string *) =
| Ostr_string
| Ostr_bytes
type out_attribute (*IF_CURRENT = Outcometree.out_attribute *) =
{ oattr_name: string }
type out_value (*IF_CURRENT = Outcometree.out_value *) =
| Oval_array of out_value list * Asttypes.mutable_flag
| Oval_char of char
| Oval_constr of out_ident * out_value list
| Oval_ellipsis
| Oval_float of float
| Oval_int of int
| Oval_int32 of int32
| Oval_int64 of int64
| Oval_nativeint of nativeint
| Oval_list of out_value list
| Oval_printer of (Caml_format_doc.formatter -> unit)
| Oval_record of (out_ident * out_value) list
| Oval_string of string * int * out_string (* string, size-to-print, kind *)
| Oval_stuff of string
| Oval_tuple of (string option * out_value) list
| Oval_variant of string * out_value option
| Oval_lazy of out_value
| Oval_floatarray of floatarray
type out_type_param (*IF_CURRENT = Outcometree.out_type_param *) = {
ot_non_gen: bool;
ot_name: string;
ot_variance: Asttypes.variance * Asttypes.injectivity
}
type out_type (*IF_CURRENT = Outcometree.out_type *) =
| Otyp_abstract
| Otyp_open
| Otyp_alias of {non_gen:bool; aliased:out_type; alias:string}
| Otyp_arrow of Asttypes.arg_label * out_type * out_type
| Otyp_class of out_ident * out_type list
| Otyp_constr of out_ident * out_type list
| Otyp_manifest of out_type * out_type
| Otyp_object of { fields: (string * out_type) list; open_row:bool}
| Otyp_record of out_label list
| Otyp_stuff of string
| Otyp_sum of out_constructor list
| Otyp_tuple of (string option * out_type) list
| Otyp_var of bool * string
| Otyp_variant of out_variant * bool * (string list) option
| Otyp_poly of string list * out_type
| Otyp_module of out_package
| Otyp_attribute of out_type * out_attribute
and out_label (*IF_CURRENT = Outcometree.out_label *) = {
olab_name: string;
olab_mut: Asttypes.mutable_flag;
olab_atomic: Asttypes.atomic_flag;
olab_type: out_type;
}
and out_constructor (*IF_CURRENT = Outcometree.out_constructor *) = {
ocstr_name: string;
ocstr_args: out_type list;
ocstr_return_type: out_type option;
}
and out_package (*IF_CURRENT = Outcometree.out_package *) = {
opack_path: out_ident;
opack_cstrs: (string * out_type) list;
}
and out_variant (*IF_CURRENT = Outcometree.out_variant *) =
| Ovar_fields of (string * bool * out_type list) list
| Ovar_typ of out_type
type out_class_type (*IF_CURRENT = Outcometree.out_class_type *) =
| Octy_constr of out_ident * out_type list
| Octy_arrow of Asttypes.arg_label * out_type * out_class_type
| Octy_signature of out_type option * out_class_sig_item list
and out_class_sig_item (*IF_CURRENT = Outcometree.out_class_sig_item *) =
| Ocsg_constraint of out_type * out_type
| Ocsg_method of string * bool * bool * out_type
| Ocsg_value of string * bool * bool * out_type
type out_module_type (*IF_CURRENT = Outcometree.out_module_type *) =
| Omty_abstract
| Omty_functor of (string option * out_module_type) option * out_module_type
| Omty_ident of out_ident
| Omty_signature of out_sig_item list
| Omty_alias of out_ident
and out_sig_item (*IF_CURRENT = Outcometree.out_sig_item *) =
| Osig_class of
bool * string * out_type_param list * out_class_type *
out_rec_status
| Osig_class_type of
bool * string * out_type_param list * out_class_type *
out_rec_status
| Osig_typext of out_extension_constructor * out_ext_status
| Osig_modtype of string * out_module_type
| Osig_module of string * out_module_type * out_rec_status
| Osig_type of out_type_decl * out_rec_status
| Osig_value of out_val_decl
| Osig_ellipsis
and out_type_decl (*IF_CURRENT = Outcometree.out_type_decl *) =
{ otype_name: string;
otype_params: out_type_param list;
otype_type: out_type;
otype_private: Asttypes.private_flag;
otype_immediate: Type_immediacy.t;
otype_unboxed: bool;
otype_cstrs: (out_type * out_type) list }
and out_extension_constructor (*IF_CURRENT = Outcometree.out_extension_constructor *) =
{ oext_name: string;
oext_type_name: string;
oext_type_params: string list;
oext_args: out_type list;
oext_ret_type: out_type option;
oext_private: Asttypes.private_flag }
and out_type_extension (*IF_CURRENT = Outcometree.out_type_extension *) =
{ otyext_name: string;
otyext_params: string list;
otyext_constructors: out_constructor list;
otyext_private: Asttypes.private_flag }
and out_val_decl (*IF_CURRENT = Outcometree.out_val_decl *) =
{ oval_name: string;
oval_type: out_type;
oval_prims: string list;
oval_attributes: out_attribute list }
and out_rec_status (*IF_CURRENT = Outcometree.out_rec_status *) =
| Orec_not
| Orec_first
| Orec_next
and out_ext_status (*IF_CURRENT = Outcometree.out_ext_status *) =
| Oext_first
| Oext_next
| Oext_exception
type out_phrase (*IF_CURRENT = Outcometree.out_phrase *) =
| Ophr_eval of out_value * out_type
| Ophr_signature of (out_sig_item * out_value option) list
| Ophr_exception of (exn * out_value)
end
================================================
FILE: src/vendored-omp/src/ast_55.ml
================================================
module Asttypes = struct
(** Auxiliary AST types used by parsetree and typedtree.
{b Warning:} this module is unstable and part of
{{!Compiler_libs}compiler-libs}.
*)
type constant (*IF_CURRENT = Asttypes.constant *) =
Const_int of int
| Const_char of char
| Const_string of string * Location.t * string option
| Const_float of string
| Const_int32 of int32
| Const_int64 of int64
| Const_nativeint of nativeint
type rec_flag (*IF_CURRENT = Asttypes.rec_flag *) = Nonrecursive | Recursive
type direction_flag (*IF_CURRENT = Asttypes.direction_flag *) = Upto | Downto
(* Order matters, used in polymorphic comparison *)
type private_flag (*IF_CURRENT = Asttypes.private_flag *) = Private | Public
type mutable_flag (*IF_CURRENT = Asttypes.mutable_flag *) = Immutable | Mutable
type atomic_flag (*IF_CURRENT = Asttypes.atomic_flag *) = Nonatomic | Atomic
type virtual_flag (*IF_CURRENT = Asttypes.virtual_flag *) = Virtual | Concrete
type override_flag (*IF_CURRENT = Asttypes.override_flag *) = Override | Fresh
type closed_flag (*IF_CURRENT = Asttypes.closed_flag *) = Closed | Open
type label = string
type arg_label (*IF_CURRENT = Asttypes.arg_label *) =
Nolabel
| Labelled of string (** [label:T -> ...] *)
| Optional of string (** [?label:T -> ...] *)
type 'a loc = 'a Location.loc = {
txt : 'a;
loc : Location.t;
}
type variance (*IF_CURRENT = Asttypes.variance *) =
| Covariant
| Contravariant
| NoVariance
| Bivariant
type injectivity (*IF_CURRENT = Asttypes.injectivity *) =
| Injective
| NoInjectivity
end
module Type_immediacy = struct
type t (*IF_CURRENT = Type_immediacy.t *) =
| Unknown
| Always
| Always_on_64bits
end
module Outcometree = struct
(* Module [Outcometree]: results displayed by the toplevel *)
(* These types represent messages that the toplevel displays as normal
results or errors. The real displaying is customisable using the hooks:
[Toploop.print_out_value]
[Toploop.print_out_type]
[Toploop.print_out_sig_item]
[Toploop.print_out_phrase] *)
(** An [out_name] is a string representation of an identifier which can be
rewritten on the fly to avoid name collisions *)
type out_name (*IF_CURRENT = Outcometree.out_name *) = { mutable printed_name: string }
type out_ident (*IF_CURRENT = Outcometree.out_ident *) =
| Oide_apply of out_ident * out_ident
| Oide_dot of out_ident * string
| Oide_ident of out_name
type out_string (*IF_CURRENT = Outcometree.out_string *) =
| Ostr_string
| Ostr_bytes
type out_attribute (*IF_CURRENT = Outcometree.out_attribute *) =
{ oattr_name: string }
type out_value (*IF_CURRENT = Outcometree.out_value *) =
| Oval_array of out_value list * Asttypes.mutable_flag
| Oval_char of char
| Oval_constr of out_ident * out_value list
| Oval_ellipsis
| Oval_float of float
| Oval_int of int
| Oval_int32 of int32
| Oval_int64 of int64
| Oval_nativeint of nativeint
| Oval_list of out_value list
| Oval_printer of (Caml_format_doc.formatter -> unit)
| Oval_record of (out_ident * out_value) list
| Oval_string of string * int * out_string (* string, size-to-print, kind *)
| Oval_stuff of string
| Oval_tuple of (string option * out_value) list
| Oval_variant of string * out_value option
| Oval_lazy of out_value
| Oval_floatarray of floatarray
type out_type_param (*IF_CURRENT = Outcometree.out_type_param *) = {
ot_non_gen: bool;
ot_name: string;
ot_variance: Asttypes.variance * Asttypes.injectivity
}
type out_type (*IF_CURRENT = Outcometree.out_type *) =
| Otyp_abstract
| Otyp_open
| Otyp_alias of {non_gen:bool; aliased:out_type; alias:string}
| Otyp_arrow of Asttypes.arg_label * out_type * out_type
| Otyp_class of out_ident * out_type list
| Otyp_constr of out_ident * out_type list
| Otyp_manifest of out_type * out_type
| Otyp_object of { fields: (string * out_type) list; row: out_row}
| Otyp_record of out_label list
| Otyp_stuff of string
| Otyp_sum of out_constructor list
| Otyp_tuple of (string option * out_type) list
| Otyp_var of bool * string
| Otyp_variant of out_variant * bool * (string list) option
| Otyp_poly of string list * out_type
| Otyp_module of out_package
| Otyp_attribute of out_type * out_attribute
| Otyp_external of string
| Otyp_functor of Asttypes.arg_label * out_ident * out_package * out_type
and out_row (*IF_CURRENT = Outcometree.out_row *) =
| Orow_closed
| Orow_open_anonymous
| Orow_open of out_type
and out_label (*IF_CURRENT = Outcometree.out_label *) = {
olab_name: string;
olab_mut: Asttypes.mutable_flag;
olab_atomic: Asttypes.atomic_flag;
olab_type: out_type;
}
and out_constructor (*IF_CURRENT = Outcometree.out_constructor *) = {
ocstr_name: string;
ocstr_args: out_type list;
ocstr_return_type: out_type option;
}
and out_package (*IF_CURRENT = Outcometree.out_package *) = {
opack_path: out_ident;
opack_constraints: (string * out_type) list;
}
and out_variant (*IF_CURRENT = Outcometree.out_variant *) =
| Ovar_fields of (string * bool * out_type list) list
| Ovar_typ of out_type
type out_class_type (*IF_CURRENT = Outcometree.out_class_type *) =
| Octy_constr of out_ident * out_type list
| Octy_arrow of Asttypes.arg_label * out_type * out_class_type
| Octy_signature of out_type option * out_class_sig_item list
and out_class_sig_item (*IF_CURRENT = Outcometree.out_class_sig_item *) =
| Ocsg_constraint of out_type * out_type
| Ocsg_method of string * bool * bool * out_type
| Ocsg_value of string * bool * bool * out_type
type out_module_type (*IF_CURRENT = Outcometree.out_module_type *) =
| Omty_abstract
| Omty_functor of (string option * out_module_type) option * out_module_type
| Omty_ident of out_ident
| Omty_signature of out_sig_item list
| Omty_alias of out_ident
and out_sig_item (*IF_CURRENT = Outcometree.out_sig_item *) =
| Osig_class of
bool * string * out_type_param list * out_class_type *
out_rec_status
| Osig_class_type of
bool * string * out_type_param list * out_class_type *
out_rec_status
| Osig_typext of out_extension_constructor * out_ext_status
| Osig_modtype of string * out_module_type
| Osig_module of string * out_module_type * out_rec_status
| Osig_type of out_type_decl * out_rec_status
| Osig_value of out_val_decl
| Osig_ellipsis
and out_type_decl (*IF_CURRENT = Outcometree.out_type_decl *) =
{ otype_name: string;
otype_params: out_type_param list;
otype_type: out_type;
otype_private: Asttypes.private_flag;
otype_immediate: Type_immediacy.t;
otype_unboxed: bool;
otype_constraints: (out_type * out_type) list }
and out_extension_constructor (*IF_CURRENT = Outcometree.out_extension_constructor *) =
{ oext_name: string;
oext_type_name: string;
oext_type_params: out_type_param list;
oext_args: out_type list;
oext_ret_type: out_type option;
oext_private: Asttypes.private_flag }
and out_type_extension (*IF_CURRENT = Outcometree.out_type_extension *) =
{ otyext_name: string;
otyext_params: out_type_param list;
otyext_constructors: out_constructor list;
otyext_private: Asttypes.private_flag }
and out_val_decl (*IF_CURRENT = Outcometree.out_val_decl *) =
{ oval_name: string;
oval_type: out_type;
oval_prims: string list;
oval_attributes: out_attribute list }
and out_rec_status (*IF_CURRENT = Outcometree.out_rec_status *) =
| Orec_not
| Orec_first
| Orec_next
and out_ext_status (*IF_CURRENT = Outcometree.out_ext_status *) =
| Oext_first
| Oext_next
| Oext_exception
type out_phrase (*IF_CURRENT = Outcometree.out_phrase *) =
| Ophr_eval of out_value * out_type
| Ophr_signature of (out_sig_item * out_value option) list
| Ophr_exception of (exn * out_value)
end
================================================
FILE: src/vendored-omp/src/caml_format_doc.cppo.ml
================================================
#if OCAML_VERSION >= (5,3,0)
include Format_doc
#else
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Florian Angeletti, projet Cambium, Inria Paris *)
(* *)
(* Copyright 2021 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
module Doc = struct
type box_type =
| H
| V
| HV
| HoV
| B
type stag = Format.stag
type element =
| Text of string
| With_size of int
| Open_box of { kind: box_type ; indent:int }
| Close_box
| Open_tag of Format.stag
| Close_tag
| Open_tbox
| Tab_break of { width : int; offset : int }
| Set_tab
| Close_tbox
| Simple_break of { spaces : int; indent: int }
| Break of { fits : string * int * string as 'a; breaks : 'a }
| Flush of { newline:bool }
| Newline
| If_newline
| Deprecated of (Format.formatter -> unit)
type t = { rev:element list } [@@unboxed]
let empty = { rev = [] }
let to_list doc = List.rev doc.rev
let add doc x = { rev = x :: doc.rev }
let fold f acc doc = List.fold_left f acc (to_list doc)
let append left right = { rev = right.rev @ left.rev }
let format_open_box_gen ppf kind indent =
match kind with
| H-> Format.pp_open_hbox ppf ()
| V -> Format.pp_open_vbox ppf indent
| HV -> Format.pp_open_hvbox ppf indent
| HoV -> Format.pp_open_hovbox ppf indent
| B -> Format.pp_open_box ppf indent
let interpret_elt ppf = function
| Text x -> Format.pp_print_string ppf x
| Open_box { kind; indent } -> format_open_box_gen ppf kind indent
| Close_box -> Format.pp_close_box ppf ()
| Open_tag tag -> Format.pp_open_stag ppf tag
| Close_tag -> Format.pp_close_stag ppf ()
| Open_tbox -> Format.pp_open_tbox ppf ()
| Tab_break {width;offset} -> Format.pp_print_tbreak ppf width offset
| Set_tab -> Format.pp_set_tab ppf ()
| Close_tbox -> Format.pp_close_tbox ppf ()
| Simple_break {spaces;indent} -> Format.pp_print_break ppf spaces indent
| Break {fits;breaks} -> Format.pp_print_custom_break ppf ~fits ~breaks
| Flush {newline=true} -> Format.pp_print_newline ppf ()
| Flush {newline=false} -> Format.pp_print_flush ppf ()
| Newline -> Format.pp_force_newline ppf ()
| If_newline -> Format.pp_print_if_newline ppf ()
| With_size _ -> ()
| Deprecated pr -> pr ppf
let rec interpret ppf = function
| [] -> ()
| With_size size :: Text text :: l ->
Format.pp_print_as ppf size text;
interpret ppf l
| x :: l ->
interpret_elt ppf x;
interpret ppf l
let format ppf doc = interpret ppf (to_list doc)
let open_box kind indent doc = add doc (Open_box {kind;indent})
let close_box doc = add doc Close_box
let string s doc = add doc (Text s)
let bytes b doc = add doc (Text (Bytes.to_string b))
let with_size size doc = add doc (With_size size)
let int n doc = add doc (Text (string_of_int n))
let float f doc = add doc (Text (string_of_float f))
let char c doc = add doc (Text (String.make 1 c))
let bool c doc = add doc (Text (Bool.to_string c))
let break ~spaces ~indent doc = add doc (Simple_break {spaces; indent})
let space doc = break ~spaces:1 ~indent:0 doc
let cut = break ~spaces:0 ~indent:0
let custom_break ~fits ~breaks doc = add doc (Break {fits;breaks})
let force_newline doc = add doc Newline
let if_newline doc = add doc If_newline
let flush doc = add doc (Flush {newline=false})
let force_stop doc = add doc (Flush {newline=true})
let open_tbox doc = add doc Open_tbox
let set_tab doc = add doc Set_tab
let tab_break ~width ~offset doc = add doc (Tab_break {width;offset})
let tab doc = tab_break ~width:0 ~offset:0 doc
let close_tbox doc = add doc Close_tbox
let open_tag stag doc = add doc (Open_tag stag)
let close_tag doc = add doc Close_tag
let iter ?(sep=Fun.id) ~iter:iterator elt l doc =
let first = ref true in
let rdoc = ref doc in
let print x =
if !first then (first := false; rdoc := elt x !rdoc)
else rdoc := !rdoc |> sep |> elt x
in
iterator print l;
!rdoc
let rec list ?(sep=Fun.id) elt l doc = match l with
| [] -> doc
| [a] -> elt a doc
| a :: ((_ :: _) as q) ->
doc |> elt a |> sep |> list ~sep elt q
let array ?sep elt a doc = iter ?sep ~iter:Array.iter elt a doc
let seq ?sep elt s doc = iter ?sep ~iter:Seq.iter elt s doc
let option ?(none=Fun.id) elt o doc = match o with
| None -> none doc
| Some x -> elt x doc
#if OCAML_VERSION >= (4,12,0)
let either ~left ~right x doc = match x with
| Either.Left x -> left x doc
| Either.Right x -> right x doc
#endif
let result ~ok ~error x doc = match x with
| Ok x -> ok x doc
| Error x -> error x doc
(* To format free-flowing text *)
let rec subtext len left right s doc =
let flush doc =
doc |> string (String.sub s left (right - left))
in
let after_flush doc = subtext len (right+1) (right+1) s doc in
if right = len then
if left <> len then flush doc else doc
else
match s.[right] with
| '\n' ->
doc |> flush |> force_newline |> after_flush
| ' ' ->
doc |> flush |> space |> after_flush
(* there is no specific support for '\t'
as it is unclear what a right semantics would be *)
| _ -> subtext len left (right + 1) s doc
let text s doc =
subtext (String.length s) 0 0 s doc
type ('a,'b) fmt = ('a, t, t, 'b) format4
type printer0 = t -> t
type 'a printer = 'a -> printer0
let output_formatting_lit fmting_lit doc =
let open CamlinternalFormatBasics in
match fmting_lit with
| Close_box -> close_box doc
| Close_tag -> close_tag doc
| Break (_, width, offset) -> break ~spaces:width ~indent:offset doc
| FFlush -> flush doc
| Force_newline -> force_newline doc
| Flush_newline -> force_stop doc
| Magic_size (_, n) -> with_size n doc
| Escaped_at -> char '@' doc
| Escaped_percent -> char '%' doc
| Scan_indic c -> doc |> char '@' |> char c
let to_string doc =
let b = Buffer.create 20 in
let convert = function
| Text s -> Buffer.add_string b s
| _ -> ()
in
fold (fun () x -> convert x) () doc;
Buffer.contents b
let box_type =
let open CamlinternalFormatBasics in
function
| Pp_fits -> H
| Pp_hbox -> H
| Pp_vbox -> V
| Pp_hovbox -> HoV
| Pp_hvbox -> HV
| Pp_box -> B
let rec compose_acc acc doc =
let open CamlinternalFormat in
match acc with
| CamlinternalFormat.Acc_formatting_lit (p, f) ->
doc |> compose_acc p |> output_formatting_lit f
| Acc_formatting_gen (p, Acc_open_tag acc') ->
let tag = to_string (compose_acc acc' empty) in
let doc = compose_acc p doc in
doc |> open_tag (Format.String_tag tag)
| Acc_formatting_gen (p, Acc_open_box acc') ->
let doc = compose_acc p doc in
let box = to_string (compose_acc acc' empty) in
let (indent, bty) = CamlinternalFormat.open_box_of_string box in
doc |> open_box (box_type bty) indent
| Acc_string_literal (p, s)
| Acc_data_string (p, s) ->
doc |> compose_acc p |> string s
| Acc_char_literal (p, c)
| Acc_data_char (p, c) -> doc |> compose_acc p |> char c
| Acc_delay (p, f) -> doc |> compose_acc p |> f
| Acc_flush p -> doc |> compose_acc p |> flush
| Acc_invalid_arg (_p, msg) -> invalid_arg msg;
| End_of_acc -> doc
let kprintf k (CamlinternalFormatBasics.Format (fmt, _)) =
CamlinternalFormat.make_printf
(fun acc doc -> doc |> compose_acc acc |> k)
End_of_acc fmt
let printf doc = kprintf Fun.id doc
let kmsg k (CamlinternalFormatBasics.Format (fmt, _)) =
CamlinternalFormat.make_printf
(fun acc -> k (compose_acc acc empty))
End_of_acc fmt
let msg fmt = kmsg Fun.id fmt
end
(** Compatibility interface *)
type doc = Doc.t
type t = doc
type formatter = doc ref
type 'a printer = formatter -> 'a -> unit
let formatter d = d
(** {1 Primitive functions }*)
let pp_print_string ppf s = ppf := Doc.string s !ppf
let pp_print_as ppf size s =
ppf := !ppf |> Doc.with_size size |> Doc.string s
let pp_print_substring ~pos ~len ppf s =
ppf := Doc.string (String.sub s pos len) !ppf
let pp_print_substring_as ~pos ~len ppf size s =
ppf :=
!ppf
|> Doc.with_size size
|> Doc.string (String.sub s pos len)
let pp_print_bytes ppf s = ppf := Doc.string (Bytes.to_string s) !ppf
let pp_print_text ppf s = ppf := Doc.text s !ppf
let pp_print_char ppf c = ppf := Doc.char c !ppf
let pp_print_int ppf c = ppf := Doc.int c !ppf
let pp_print_float ppf f = ppf := Doc.float f !ppf
let pp_print_bool ppf b = ppf := Doc.bool b !ppf
let pp_print_nothing _ _ = ()
let pp_close_box ppf () = ppf := Doc.close_box !ppf
let pp_close_stag ppf () = ppf := Doc.close_tag !ppf
let pp_print_break ppf spaces indent = ppf := Doc.break ~spaces ~indent !ppf
let pp_print_custom_break ppf ~fits ~breaks =
ppf := Doc.custom_break ~fits ~breaks !ppf
let pp_print_space ppf () = pp_print_break ppf 1 0
let pp_print_cut ppf () = pp_print_break ppf 0 0
let pp_print_flush ppf () = ppf := Doc.flush !ppf
let pp_force_newline ppf () = ppf := Doc.force_newline !ppf
let pp_print_newline ppf () = ppf := Doc.force_stop !ppf
let pp_print_if_newline ppf () =ppf := Doc.if_newline !ppf
let pp_open_stag ppf stag = ppf := !ppf |> Doc.open_tag stag
let pp_open_box_gen ppf indent bxty =
let box_type = Doc.box_type bxty in
ppf := !ppf |> Doc.open_box box_type indent
let pp_open_box ppf indent = pp_open_box_gen ppf indent Pp_box
let pp_open_tbox ppf () = ppf := !ppf |> Doc.open_tbox
let pp_close_tbox ppf () = ppf := !ppf |> Doc.close_tbox
let pp_set_tab ppf () = ppf := !ppf |> Doc.set_tab
let pp_print_tab ppf () = ppf := !ppf |> Doc.tab
let pp_print_tbreak ppf width offset =
ppf := !ppf |> Doc.tab_break ~width ~offset
let pp_doc ppf doc = ppf := Doc.append !ppf doc
module Driver = struct
(* Interpret a formatting entity on a formatter. *)
let output_formatting_lit ppf
(fmting_lit:CamlinternalFormatBasics.formatting_lit)
= match fmting_lit with
| Close_box -> pp_close_box ppf ()
| Close_tag -> pp_close_stag ppf ()
| Break (_, width, offset) -> pp_print_break ppf width offset
| FFlush -> pp_print_flush ppf ()
| Force_newline -> pp_force_newline ppf ()
| Flush_newline -> pp_print_newline ppf ()
| Magic_size (_, _) -> ()
| Escaped_at -> pp_print_char ppf '@'
| Escaped_percent -> pp_print_char ppf '%'
| Scan_indic c -> pp_print_char ppf '@'; pp_print_char ppf c
let compute_tag output tag_acc =
let buf = Buffer.create 16 in
let buf_fmt = Format.formatter_of_buffer buf in
let ppf = ref Doc.empty in
output ppf tag_acc;
pp_print_flush ppf ();
Doc.format buf_fmt !ppf;
let len = Buffer.length buf in
if len < 2 then Buffer.contents buf
else Buffer.sub buf 1 (len - 2)
(* Recursively output an "accumulator" containing a reversed list of
printing entities (string, char, flus, ...) in an output_stream. *)
(* Differ from Printf.output_acc by the interpretation of formatting. *)
(* Used as a continuation of CamlinternalFormat.make_printf. *)
let rec output_acc ppf (acc: _ CamlinternalFormat.acc) =
match acc with
| Acc_string_literal (Acc_formatting_lit (p, Magic_size (_, size)), s)
| Acc_data_string (Acc_formatting_lit (p, Magic_size (_, size)), s) ->
output_acc ppf p;
pp_print_as ppf size s;
| Acc_char_literal (Acc_formatting_lit (p, Magic_size (_, size)), c)
| Acc_data_char (Acc_formatting_lit (p, Magic_size (_, size)), c) ->
output_acc ppf p;
pp_print_as ppf size (String.make 1 c);
| Acc_formatting_lit (p, f) ->
output_acc ppf p;
output_formatting_lit ppf f;
| Acc_formatting_gen (p, Acc_open_tag acc') ->
output_acc ppf p;
pp_open_stag ppf (Format.String_tag (compute_tag output_acc acc'))
| Acc_formatting_gen (p, Acc_open_box acc') ->
output_acc ppf p;
let (indent, bty) =
let box_info = compute_tag output_acc acc' in
CamlinternalFormat.open_box_of_string box_info
in
pp_open_box_gen ppf indent bty
| Acc_string_literal (p, s)
| Acc_data_string (p, s) -> output_acc ppf p; pp_print_string ppf s;
| Acc_char_literal (p, c)
| Acc_data_char (p, c) -> output_acc ppf p; pp_print_char ppf c;
| Acc_delay (p, f) -> output_acc ppf p; f ppf;
| Acc_flush p -> output_acc ppf p; pp_print_flush ppf ();
| Acc_invalid_arg (p, msg) -> output_acc ppf p; invalid_arg msg;
| End_of_acc -> ()
end
let kfprintf k ppf (CamlinternalFormatBasics.Format (fmt, _)) =
CamlinternalFormat.make_printf
(fun acc -> Driver.output_acc ppf acc; k ppf)
End_of_acc fmt
let fprintf doc fmt = kfprintf ignore doc fmt
let kdprintf k (CamlinternalFormatBasics.Format (fmt, _)) =
CamlinternalFormat.make_printf
(fun acc -> k (fun ppf -> Driver.output_acc ppf acc))
End_of_acc fmt
let dprintf fmt = kdprintf (fun i -> i) fmt
let doc_printf fmt =
let ppf = ref Doc.empty in
kfprintf (fun _ -> let doc = !ppf in ppf := Doc.empty; doc) ppf fmt
let kdoc_printf k fmt =
let ppf = ref Doc.empty in
kfprintf (fun ppf ->
let doc = !ppf in
ppf := Doc.empty;
k doc
)
ppf fmt
let doc_printer f x doc =
let r = ref doc in
f r x;
!r
type 'a format_printer = Format.formatter -> 'a -> unit
let format_printer f ppf x =
let doc = doc_printer f x Doc.empty in
Doc.format ppf doc
let compat = format_printer
let compat1 f p1 = compat (f p1)
let compat2 f p1 p2 = compat (f p1 p2)
let kasprintf k fmt =
kdoc_printf (fun doc -> k (Format.asprintf "%a" Doc.format doc)) fmt
let asprintf fmt = kasprintf Fun.id fmt
let pp_print_iter ?(pp_sep=pp_print_cut) iter elt ppf c =
let sep = doc_printer pp_sep () in
ppf := Doc.iter ~sep ~iter (doc_printer elt) c !ppf
let pp_print_list ?(pp_sep=pp_print_cut) elt ppf l =
ppf := Doc.list ~sep:(doc_printer pp_sep ()) (doc_printer elt) l !ppf
let pp_print_array ?pp_sep elt ppf a =
pp_print_iter ?pp_sep Array.iter elt ppf a
let pp_print_seq ?pp_sep elt ppf s = pp_print_iter ?pp_sep Seq.iter elt ppf s
let pp_print_option ?(none=fun _ () -> ()) elt ppf o =
ppf := Doc.option ~none:(doc_printer none ()) (doc_printer elt) o !ppf
let pp_print_result ~ok ~error ppf r =
ppf := Doc.result ~ok:(doc_printer ok) ~error:(doc_printer error) r !ppf
#if OCAML_VERSION >= (4,12,0)
let pp_print_either ~left ~right ppf e =
ppf := Doc.either ~left:(doc_printer left) ~right:(doc_printer right) e !ppf
#endif
let comma ppf () = fprintf ppf ",@ "
let pp_two_columns ?(sep = "|") ?max_lines ppf (lines: (string * string) list) =
let left_column_size =
List.fold_left (fun acc (s, _) -> max acc (String.length s)) 0 lines in
let lines_nb = List.length lines in
let ellipsed_first, ellipsed_last =
match max_lines with
| Some max_lines when lines_nb > max_lines ->
let printed_lines = max_lines - 1 in (* the ellipsis uses one line *)
let lines_before = printed_lines / 2 + printed_lines mod 2 in
let lines_after = printed_lines / 2 in
(lines_before, lines_nb - lines_after - 1)
| _ -> (-1, -1)
in
fprintf ppf "@[<v>";
List.iteri (fun k (line_l, line_r) ->
if k = ellipsed_first then fprintf ppf "...@,";
if ellipsed_first <= k && k <= ellipsed_last then ()
else fprintf ppf "%*s %s %s@," left_column_size line_l sep line_r
) lines;
fprintf ppf "@]"
let deprecated_printer pr ppf = ppf := Doc.add !ppf (Doc.Deprecated pr)
let deprecated pr ppf x =
ppf := Doc.add !ppf (Doc.Deprecated (fun ppf -> pr ppf x))
let deprecated1 pr p1 ppf x =
ppf := Doc.add !ppf (Doc.Deprecated (fun ppf -> pr p1 ppf x))
#endif
================================================
FILE: src/vendored-omp/src/cinaps_helpers
================================================
(* -*- tuareg -*- *)
open StdLabels
open Printf
let nl () = printf "\n"
let supported_versions = [
("402", "4.02");
("403", "4.03");
("404", "4.04");
("405", "4.05");
("406", "4.06");
("407", "4.07");
("408", "4.08");
("409", "4.09");
("410", "4.10");
("411", "4.11");
("412", "4.12");
("413", "4.13");
("414", "4.14");
("500", "5.0");
("51", "5.1");
("52", "5.2");
("53", "5.3");
("54", "5.4");
]
let qualified_types = [
"Outcometree",
[ "out_value"
; "out_type"
; "out_class_type"
; "out_module_type"
; "out_sig_item"
; "out_type_extension"
; "out_phrase"
];
]
let all_types = List.concat (List.map ~f:snd qualified_types)
let foreach_module f =
nl ();
List.iter qualified_types ~f:(fun (m, types) -> f m types)
let foreach_type f =
foreach_module (fun m -> List.iter ~f:(f m))
let foreach_version f =
nl ();
List.iter supported_versions ~f:(fun (suffix, version) -> f suffix version)
let foreach_version_pair f =
nl ();
let rec aux = function
| (x,_) :: ((y,_) :: _ as tail) -> f x y; aux tail
| [_] | [] -> ()
in
aux supported_versions
let with_then_and () =
let first = ref true in fun oc ->
output_string oc (if !first then "with" else "and");
first := false
================================================
FILE: src/vendored-omp/src/compiler-functions/ge_406_and_lt_408.ml
================================================
let error_of_exn exn =
match Location.error_of_exn exn with
| Some (`Ok exn) -> Some exn
| Some `Already_displayed -> None
| None -> None
let get_load_paths () =
!Config.load_path
let load_path_init l =
Config.load_path := l
let get_unboxed_types () =
!Clflags.unboxed_types
let set_unboxed_types b =
Clflags.unboxed_types := b
let may_map = Misc.may_map
let bad_docstring t = Warnings.Bad_docstring t
================================================
FILE: src/vendored-omp/src/compiler-functions/ge_408_and_lt_410.ml
================================================
let error_of_exn exn =
match Location.error_of_exn exn with
| Some (`Ok exn) -> Some exn
| Some `Already_displayed -> None
| None -> None
let get_load_paths () =
Load_path.get_paths ()
let load_path_init l =
Load_path.init l
let get_unboxed_types () =
!Clflags.unboxed_types
let set_unboxed_types b =
Clflags.unboxed_types := b
let may_map = Misc.may_map
let bad_docstring t = Warnings.Bad_docstring t
================================================
FILE: src/vendored-omp/src/compiler-functions/ge_410_and_lt_412.ml
================================================
let error_of_exn exn =
match Location.error_of_exn exn with
| Some (`Ok exn) -> Some exn
| Some `Already_displayed -> None
| None -> None
let get_load_paths () =
Load_path.get_paths ()
let load_path_init l =
Load_path.init l
let get_unboxed_types () =
!Clflags.unboxed_types
let set_unboxed_types b =
Clflags.unboxed_types := b
let may_map = Option.map
let bad_docstring t = Warnings.Bad_docstring t
================================================
FILE: src/vendored-omp/src/compiler-functions/ge_412.ml
================================================
let error_of_exn exn =
match Location.error_of_exn exn with
| Some (`Ok exn) -> Some exn
| Some `Already_displayed -> None
| None -> None
let get_load_paths () =
Load_path.get_paths ()
let load_path_init l =
Load_path.init l
let get_unboxed_types () =
!Clflags.unboxed_types
let set_unboxed_types b =
Clflags.unboxed_types := b
let may_map = Option.map
let bad_docstring t = Warnings.Unexpected_docstring t
================================================
FILE: src/vendored-omp/src/compiler-functions/ge_50.ml
================================================
let error_of_exn exn =
match Location.error_of_exn exn with
| Some (`Ok exn) -> Some exn
| Some `Already_displayed -> None
| None -> None
let get_load_paths () =
Load_path.get_paths ()
let load_path_init l =
let auto_include find_in_dir fn =
if !Clflags.no_std_include then
raise Not_found
else
let alert = Location.auto_include_alert in
Load_path.auto_include_otherlibs alert find_in_dir fn
in
Load_path.init ~auto_include l
let get_unboxed_types () =
!Clflags.unboxed_types
let set_unboxed_types b =
Clflags.unboxed_types := b
let may_map = Option.map
let bad_docstring t = Warnings.Unexpected_docstring t
================================================
FILE: src/vendored-omp/src/compiler-functions/ge_52.ml
================================================
let error_of_exn exn =
match Location.error_of_exn exn with
| Some (`Ok exn) -> Some exn
| Some `Already_displayed -> None
| None -> None
let get_load_paths () =
Load_path.get_paths ()
let load_path_init l =
let auto_include find_in_dir fn =
if !Clflags.no_std_include then
raise Not_found
else
let alert = Location.auto_include_alert in
Load_path.auto_include_otherlibs alert find_in_dir fn
in
Load_path.init ~auto_include ~visible:l ~hidden:[]
let get_unboxed_types () =
!Clflags.unboxed_types
let set_unboxed_types b =
Clflags.unboxed_types := b
let may_map = Option.map
let bad_docstring t = Warnings.Unexpected_docstring t
================================================
FILE: src/vendored-omp/src/compiler-functions/lt_406.ml
================================================
let error_of_exn = Location.error_of_exn
let get_load_paths () =
!Config.load_path
let load_path_init l =
Config.load_path := l
let get_unboxed_types () =
false
let set_unboxed_types _b =
()
let may_map = Misc.may_map
let bad_docstring t = Warnings.Bad_docstring t
================================================
FILE: src/vendored-omp/src/config/gen.ml
================================================
let write fn s =
let oc = open_out fn in
output_string oc s;
close_out oc
let () =
let ocaml_version_str = Sys.argv.(1) in
let ocaml_version =
Scanf.sscanf ocaml_version_str "%u.%u" (fun a b -> (a, b))
in
write "ast-version"
(match ocaml_version with
| (4, 02) -> "402"
| (4, 03) -> "403"
| (4, 04) -> "404"
| (4, 05) -> "405"
| (4, 06) -> "406"
| (4, 07) -> "407"
| (4, 08) -> "408"
| (4, 09) -> "409"
| (4, 10) -> "410"
| (4, 11) -> "411"
| (4, 12) -> "412"
| (4, 13) -> "413"
| (4, 14) -> "414"
| (5, 0) -> "500"
| (5, 1) -> "51"
| (5, 2) -> "52"
| (5, 3) -> "53"
| (5, 4) -> "54"
| (5, 5) -> "55"
| _ ->
Printf.eprintf "Unknown OCaml version %s\n" ocaml_version_str;
exit 1);
write "compiler-functions-file"
(if ocaml_version < (4, 06) then
"lt_406.ml"
else if ocaml_version < (4, 08) then
"ge_406_and_lt_408.ml"
else if ocaml_version < (4, 10) then
"ge_408_and_lt_410.ml"
else if ocaml_version < (4, 12) then
"ge_410_and_lt_412.ml"
else if ocaml_version < (5, 00) then
"ge_412.ml"
else if ocaml_version < (5, 2) then
"ge_50.ml"
else
"ge_52.ml"
)
================================================
FILE: src/vendored-omp/src/dune
================================================
(library
(name reason_omp)
(public_name reason.ocaml-migrate-parsetree)
(wrapped true)
(libraries ppxlib.astlib)
(modules :standard \ migrate_parsetree_driver_main)
(preprocess
(action
(run %{exe:../tools/pp.exe} %{read:ast-version} %{input-file})))
; (ppx.driver
; (main Migrate_parsetree.Driver.run_main)
; (flags --dump-ast)
; (lint_flags --null))
)
(rule
(targets caml_format_doc.ml)
(deps caml_format_doc.cppo.ml)
(action
(run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets})))
; Not needed for reason repo (vendored)
; (library
; (name reason.migrate_parsetree_driver_main)
; (public_name reason.ocaml-migrate-parsetree.driver-main)
; (modules reason.migrate_parsetree_driver_main)
; (library_flags -linkall)
; (libraries reason_migrate_parsetree))
(rule
(copy#
compiler-functions/%{read:compiler-functions-file}
migrate_parsetree_compiler_functions.ml))
(rule
(targets ast-version compiler-functions-file)
(action
(run %{ocaml} %{dep:config/gen.ml} %{ocaml_version})))
================================================
FILE: src/vendored-omp/src/locations.ml
================================================
type old_location_error (*IF_NOT_AT_LEAST 408 = Location.error *) = {
loc: Location.t;
msg: string;
sub: old_location_error list;
if_highlight: string;
}
type location_msg =
(*IF_AT_LEAST 53 Format_doc.t Location.loc *)
(*IF_NOT_AT_LEAST 53 (Format.formatter -> unit) Location.loc *)
type location_report_kind (*IF_AT_LEAST 408 = Location.report_kind *) =
| Report_error
| Report_warning of string
| Report_warning_as_error of string
| Report_alert of string
| Report_alert_as_error of string
type location_report (*IF_AT_LEAST 408 = Location.report *) = {
kind : location_report_kind;
main : location_msg;
sub : location_msg list;
(*IF_AT_LEAST 53 footnote: Format_doc.t option *)
}
type location_error (*IF_AT_LEAST 408 = Location.error *) (*IF_NOT_AT_LEAST 408 = old_location_error *)
type error_type = [`Report of location_report | `Old_error of old_location_error]
let error_type_of_location_error : location_error -> error_type = fun x ->
(*IF_AT_LEAST 408 `Report x *)
(*IF_NOT_AT_LEAST 408 `Old_error x *)
let location_error_of_exn : exn -> location_error = fun exn ->
(*IF_AT_LEAST 408 match Location.error_of_exn exn with None | Some `Already_displayed -> raise exn | Some (`Ok e) -> e *)
(*IF_NOT_AT_LEAST 408 match Migrate_parsetree_compiler_functions.error_of_exn exn with None -> raise exn | Some e -> e*)
let extension_of_error ~mk_pstr ~mk_extension ~mk_string_constant (error : location_error) =
match error_type_of_location_error error with
| `Old_error old_error ->
let rec extension_of_old_error ({loc; msg; if_highlight = _; sub} : old_location_error) =
{ Location.loc; txt = "ocaml.error" },
mk_pstr ((mk_string_constant msg) ::
(List.map (fun ext -> mk_extension (extension_of_old_error ext)) sub)) in
extension_of_old_error old_error
| `Report report ->
let extension_of_report ({kind; main; sub;_} : location_report) =
if kind <> Report_error then
raise (Invalid_argument "extension_of_error: expected kind Report_error");
(*IF_AT_LEAST 53 let str_of_pp pp_msg = Format.asprintf "%a" Format_doc.Doc.format pp_msg in *)
(*IF_NOT_AT_LEAST 53 let str_of_pp pp_msg = Format.asprintf "%t" pp_msg in *)
let extension_of_sub (sub : location_msg) =
{ Location.loc = sub.loc; txt = "ocaml.error" },
mk_pstr ([mk_string_constant (str_of_pp sub.txt)])
in
{ Location.loc = main.loc; txt = "ocaml.error" },
mk_pstr (mk_string_constant (str_of_pp main.txt) ::
List.map (fun msg -> mk_extension (extension_of_sub msg)) sub) in
extension_of_report report
let error_of_exn exn =
try Some (location_error_of_exn exn) with _ -> None
let register_error_of_exn f = Location.register_error_of_exn f
let report_exception ppf exn = Location.report_exception ppf exn
let errorf ~loc fmt = Location.errorf ~loc ~sub:[] fmt
let raise_errorf ?(loc = Location.none) fmt = Location.raise_errorf ~loc ~sub:[] fmt
let _get_error_message_old location_error =
location_error.msg
let _get_error_message_new location_error =
let buff = Buffer.create 128 in
let ppf = Format.formatter_of_buffer buff in
(*IF_AT_LEAST 53 Format_doc.Doc.format ppf location_error.main.txt; *)
(*IF_NOT_AT_LEAST 53 location_error.main.txt ppf; *)
Format.pp_print_flush ppf ();
Buffer.contents buff
let get_error_message location_error =
(*IF_NOT_AT_LEAST 408 _get_error_message_old location_error*)
(*IF_AT_LEAST 408 _get_error_message_new location_error*)
let _set_error_message_old location_error msg =
{ location_error with msg; }
let _set_error_message_new location_error msg =
(*IF_AT_LEAST 53 let txt = Format_doc.Doc.msg "%s" msg in *)
(*IF_NOT_AT_LEAST 53 let txt ppf = Format.pp_print_string ppf msg in *)
let main = { location_error.main with txt; } in
{ location_error with main }
let set_error_message location_error msg =
(*IF_NOT_AT_LEAST 408 _set_error_message_old location_error msg*)
(*IF_AT_LEAST 408 _set_error_message_new location_error msg*)
let make_error_of_message_old ~loc msg ~sub =
let sub = List.map (fun (loc, msg) -> { loc; msg; sub = []; if_highlight = msg; }) sub in
{ loc; msg; sub; if_highlight = msg; }
let make_error_of_message_new ~loc msg ~sub =
(*IF_AT_LEAST 53 let mk_txt x = Format_doc.Doc.msg "%s" x in *)
(*IF_NOT_AT_LEAST 53 let mk_txt x ppf = Format.pp_print_string ppf x in *)
let mk loc x = { Location.loc; txt = mk_txt x; } in
{ kind = Report_error;
main = mk loc msg;
sub = List.map (fun (loc, msg) -> mk loc msg) sub;
(*IF_AT_LEAST 53 footnote = None *)
}
let make_error_of_message ~loc msg ~sub =
(*IF_NOT_AT_LEAST 408 make_error_of_message_old ~loc msg ~sub*)
(*IF_AT_LEAST 408 make_error_of_message_new ~loc msg ~sub*)
let print_error ppf err =
(*IF_NOT_AT_LEAST 408 Location.report_error ppf err*)
(*IF_AT_LEAST 408 Location.print_report ppf err*)
module type Helpers_intf = sig
type nonrec location_error = location_error
val error_of_exn : exn -> location_error option
val register_error_of_exn : (exn -> location_error option) -> unit
val report_exception : Format.formatter -> exn -> unit
val get_error_message : location_error -> string
val set_error_message : location_error -> string -> location_error
val make_error_of_message : loc:Location.t -> string -> sub:(Location.t * string) list -> location_error
val print_error : Format.formatter -> location_error -> unit
val raise_error : location_error -> 'a
end
module Helpers_impl = struct
type nonrec location_error = location_error
let error_of_exn = error_of_exn
let register_error_of_exn = register_error_of_exn
let report_exception = report_exception
let get_error_message = get_error_message
let set_error_message = set_error_message
let make_error_of_message = make_error_of_message
let print_error = print_error
let raise_error err = raise (Location.Error err)
end
================================================
FILE: src/vendored-omp/src/migrate_parsetree_408_409.ml
================================================
(**************************************************************************)
(* *)
(* OCaml Migrate Parsetree *)
(* *)
(* Frédéric Bour *)
(* *)
(* Copyright 2017 Institut National de Recherche en Informatique et *)
(* en Automatique (INRIA). *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
include Migrate_parsetree_408_409_migrate
================================================
FILE: src/vendored-omp/src/migrate_parsetree_408_409_migrate.ml
================================================
open Stdlib0
module From = Ast_408
module To = Ast_409
let rec copy_out_type_extension :
Ast_408.Outcometree.out_type_extension ->
Ast_409.Outcometree.out_type_extension
=
fun
{ Ast_408.Outcometree.otyext_name = otyext_name;
Ast_408.Outcometree.otyext_params = otyext_params;
Ast_408.Outcometree.otyext_constructors = otyext_constructors;
Ast_408.Outcometree.otyext_private = otyext_private }
->
{
Ast_409.Outcometree.otyext_name = otyext_name;
Ast_409.Outcometree.otyext_params =
(List.map (fun x -> x) otyext_params);
Ast_409.Outcometree.otyext_constructors =
(List.map
(fun x ->
let (x0, x1, x2) = x in
(x0, (List.map copy_out_type x1),
(Option.map copy_out_type x2))) otyext_constructors);
Ast_409.Outcometree.otyext_private = (copy_private_flag otyext_private)
}
and copy_out_phrase :
Ast_408.Outcometree.out_phrase -> Ast_409.Outcometree.out_phrase =
function
| Ast_408.Outcometree.Ophr_eval (x0, x1) ->
Ast_409.Outcometree.Ophr_eval ((copy_out_value x0), (copy_out_type x1))
| Ast_408.Outcometree.Ophr_signature x0 ->
Ast_409.Outcometree.Ophr_signature
(List.map
(fun x ->
let (x0, x1) = x in
((copy_out_sig_item x0), (Option.map copy_out_value x1))) x0)
| Ast_408.Outcometree.Ophr_exception x0 ->
Ast_409.Outcometree.Ophr_exception
(let (x0, x1) = x0 in (x0, (copy_out_value x1)))
and copy_out_sig_item :
Ast_408.Outcometree.out_sig_item -> Ast_409.Outcometree.out_sig_item =
function
| Ast_408.Outcometree.Osig_class (x0, x1, x2, x3, x4) ->
Ast_409.Outcometree.Osig_class
(x0, x1,
(List.map
(fun x ->
let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) x2),
(copy_out_class_type x3), (copy_out_rec_status x4))
| Ast_408.Outcometree.Osig_class_type (x0, x1, x2, x3, x4) ->
Ast_409.Outcometree.Osig_class_type
(x0, x1,
(List.map
(fun x ->
let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) x2),
(copy_out_class_type x3), (copy_out_rec_status x4))
| Ast_408.Outcometree.Osig_typext (x0, x1) ->
Ast_409.Outcometree.Osig_typext
((copy_out_extension_constructor x0), (copy_out_ext_status x1))
| Ast_408.Outcometree.Osig_modtype (x0, x1) ->
Ast_409.Outcometree.Osig_modtype (x0, (copy_out_module_type x1))
| Ast_408.Outcometree.Osig_module (x0, x1, x2) ->
Ast_409.Outcometree.Osig_module
(x0, (copy_out_module_type x1), (copy_out_rec_status x2))
| Ast_408.Outcometree.Osig_type (x0, x1) ->
Ast_409.Outcometree.Osig_type
((copy_out_type_decl x0), (copy_out_rec_status x1))
| Ast_408.Outcometree.Osig_value x0 ->
Ast_409.Outcometree.Osig_value (copy_out_val_decl x0)
| Ast_408.Outcometree.Osig_ellipsis -> Ast_409.Outcometree.Osig_ellipsis
and copy_out_val_decl :
Ast_408.Outcometree.out_val_decl -> Ast_409.Outcometree.out_val_decl =
fun
{ Ast_408.Outcometree.oval_name = oval_name;
Ast_408.Outcometree.oval_type = oval_type;
Ast_408.Outcometree.oval_prims = oval_prims;
Ast_408.Outcometree.oval_attributes = oval_attributes }
->
{
Ast_409.Outcometree.oval_name = oval_name;
Ast_409.Outcometree.oval_type = (copy_out_type oval_type);
Ast_409.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims);
Ast_409.Outcometree.oval_attributes =
(List.map copy_out_attribute oval_attributes)
}
and copy_out_type_decl :
Ast_408.Outcometree.out_type_decl -> Ast_409.Outcometree.out_type_decl =
fun
{ Ast_408.Outcometree.otype_name = otype_name;
Ast_408.Outcometree.otype_params = otype_params;
Ast_408.Outcometree.otype_type = otype_type;
Ast_408.Outcometree.otype_private = otype_private;
Ast_408.Outcometree.otype_immediate = otype_immediate;
Ast_408.Outcometree.otype_unboxed = otype_unboxed;
Ast_408.Outcometree.otype_cstrs = otype_cstrs }
->
{
Ast_409.Outcometree.otype_name = otype_name;
Ast_409.Outcometree.otype_params =
(List.map
(fun x ->
let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1))))
otype_params);
Ast_409.Outcometree.otype_type = (copy_out_type otype_type);
Ast_409.Outcometree.otype_private = (copy_private_flag otype_private);
Ast_409.Outcometree.otype_immediate = otype_immediate;
Ast_409.Outcometree.otype_unboxed = otype_unboxed;
Ast_409.Outcometree.otype_cstrs =
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_type x0), (copy_out_type x1)))
otype_cstrs)
}
and copy_out_module_type :
Ast_408.Outcometree.out_module_type -> Ast_409.Outcometree.out_module_type
=
function
| Ast_408.Outcometree.Omty_abstract -> Ast_409.Outcometree.Omty_abstract
| Ast_408.Outcometree.Omty_functor (x0, x1, x2) ->
Ast_409.Outcometree.Omty_functor
(x0, (Option.map copy_out_module_type x1), (copy_out_module_type x2))
| Ast_408.Outcometree.Omty_ident x0 ->
Ast_409.Outcometree.Omty_ident (copy_out_ident x0)
| Ast_408.Outcometree.Omty_signature x0 ->
Ast_409.Outcometree.Omty_signature (List.map copy_out_sig_item x0)
| Ast_408.Outcometree.Omty_alias x0 ->
Ast_409.Outcometree.Omty_alias (copy_out_ident x0)
and copy_out_ext_status :
Ast_408.Outcometree.out_ext_status -> Ast_409.Outcometree.out_ext_status =
function
| Ast_408.Outcometree.Oext_first -> Ast_409.Outcometree.Oext_first
| Ast_408.Outcometree.Oext_next -> Ast_409.Outcometree.Oext_next
| Ast_408.Outcometree.Oext_exception -> Ast_409.Outcometree.Oext_exception
and copy_out_extension_constructor :
Ast_408.Outcometree.out_extension_constructor ->
Ast_409.Outcometree.out_extension_constructor
=
fun
{ Ast_408.Outcometree.oext_name = oext_name;
Ast_408.Outcometree.oext_type_name = oext_type_name;
Ast_408.Outcometree.oext_type_params = oext_type_params;
Ast_408.Outcometree.oext_args = oext_args;
Ast_408.Outcometree.oext_ret_type = oext_ret_type;
Ast_408.Outcometree.oext_private = oext_private }
->
{
Ast_409.Outcometree.oext_name = oext_name;
Ast_409.Outcometree.oext_type_name = oext_type_name;
Ast_409.Outcometree.oext_type_params =
(List.map (fun x -> x) oext_type_params);
Ast_409.Outcometree.oext_args = (List.map copy_out_type oext_args);
Ast_409.Outcometree.oext_ret_type =
(Option.map copy_out_type oext_ret_type);
Ast_409.Outcometree.oext_private = (copy_private_flag oext_private)
}
and copy_private_flag :
Ast_408.Asttypes.private_flag -> Ast_409.Asttypes.private_flag =
function
| Ast_408.Asttypes.Private -> Ast_409.Asttypes.Private
| Ast_408.Asttypes.Public -> Ast_409.Asttypes.Public
and copy_out_rec_status :
Ast_408.Outcometree.out_rec_status -> Ast_409.Outcometree.out_rec_status =
function
| Ast_408.Outcometree.Orec_not -> Ast_409.Outcometree.Orec_not
| Ast_408.Outcometree.Orec_first -> Ast_409.Outcometree.Orec_first
| Ast_408.Outcometree.Orec_next -> Ast_409.Outcometree.Orec_next
and copy_out_class_type :
Ast_408.Outcometree.out_class_type -> Ast_409.Outcometree.out_class_type =
function
| Ast_408.Outcometree.Octy_constr (x0, x1) ->
Ast_409.Outcometree.Octy_constr
((copy_out_ident x0), (List.map copy_out_type x1))
| Ast_408.Outcometree.Octy_arrow (x0, x1, x2) ->
Ast_409.Outcometree.Octy_arrow
(x0, (copy_out_type x1), (copy_out_class_type x2))
| Ast_408.Outcometree.Octy_signature (x0, x1) ->
Ast_409.Outcometree.Octy_signature
((Option.map copy_out_type x0),
(List.map copy_out_class_sig_item x1))
and copy_out_class_sig_item :
Ast_408.Outcometree.out_class_sig_item ->
Ast_409.Outcometree.out_class_sig_item
=
function
| Ast_408.Outcometree.Ocsg_constraint (x0, x1) ->
Ast_409.Outcometree.Ocsg_constraint
((copy_out_type x0), (copy_out_type x1))
| Ast_408.Outcometree.Ocsg_method (x0, x1, x2, x3) ->
Ast_409.Outcometree.Ocsg_method (x0, x1, x2, (copy_out_type x3))
| Ast_408.Outcometree.Ocsg_value (x0, x1, x2, x3) ->
Ast_409.Outcometree.Ocsg_value (x0, x1, x2, (copy_out_type x3))
and copy_out_type :
Ast_408.Outcometree.out_type -> Ast_409.Outcometree.out_type =
function
| Ast_408.Outcometree.Otyp_abstract -> Ast_409.Outcometree.Otyp_abstract
| Ast_408.Outcometree.Otyp_open -> Ast_409.Outcometree.Otyp_open
| Ast_408.Outcometree.Otyp_alias (x0, x1) ->
Ast_409.Outcometree.Otyp_alias ((copy_out_type x0), x1)
| Ast_408.Outcometree.Otyp_arrow (x0, x1, x2) ->
Ast_409.Outcometree.Otyp_arrow
(x0, (copy_out_type x1), (copy_out_type x2))
| Ast_408.Outcometree.Otyp_class (x0, x1, x2) ->
Ast_409.Outcometree.Otyp_class
(x0, (copy_out_ident x1), (List.map copy_out_type x2))
| Ast_408.Outcometree.Otyp_constr (x0, x1) ->
Ast_409.Outcometree.Otyp_constr
((copy_out_ident x0), (List.map copy_out_type x1))
| Ast_408.Outcometree.Otyp_manifest (x0, x1) ->
Ast_409.Outcometree.Otyp_manifest
((copy_out_type x0), (copy_out_type x1))
| Ast_408.Outcometree.Otyp_object (x0, x1) ->
Ast_409.Outcometree.Otyp_object
((List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1))) x0),
(Option.map (fun x -> x) x1))
| Ast_408.Outcometree.Otyp_record x0 ->
Ast_409.Outcometree.Otyp_record
(List.map
(fun x -> let (x0, x1, x2) = x in (x0, x1, (copy_out_type x2))) x0)
| Ast_408.Outcometree.Otyp_stuff x0 -> Ast_409.Outcometree.Otyp_stuff x0
| Ast_408.Outcometree.Otyp_sum x0 ->
Ast_409.Outcometree.Otyp_sum
(List.map
(fun x ->
let (x0, x1, x2) = x in
(x0, (List.map copy_out_type x1),
(Option.map copy_out_type x2))) x0)
| Ast_408.Outcometree.Otyp_tuple x0 ->
Ast_409.Outcometree.Otyp_tuple (List.map copy_out_type x0)
| Ast_408.Outcometree.Otyp_var (x0, x1) ->
Ast_409.Outcometree.Otyp_var (x0, x1)
| Ast_408.Outcometree.Otyp_variant (x0, x1, x2, x3) ->
Ast_409.Outcometree.Otyp_variant
(x0, (copy_out_variant x1), x2,
(Option.map (fun x -> List.map (fun x -> x) x) x3))
| Ast_408.Outcometree.Otyp_poly (x0, x1) ->
Ast_409.Outcometree.Otyp_poly
((List.map (fun x -> x) x0), (copy_out_type x1))
| Ast_408.Outcometree.Otyp_module (x0, x1, x2) ->
Ast_409.Outcometree.Otyp_module
((copy_out_ident x0), (List.map (fun x -> x) x1),
(List.map copy_out_type x2))
| Ast_408.Outcometree.Otyp_attribute (x0, x1) ->
Ast_409.Outcometree.Otyp_attribute
((copy_out_type x0), (copy_out_attribute x1))
and copy_out_attribute :
Ast_408.Outcometree.out_attribute -> Ast_409.Outcometree.out_attribute =
fun { Ast_408.Outcometree.oattr_name = oattr_name } ->
{ Ast_409.Outcometree.oattr_name = oattr_name }
and copy_out_variant :
Ast_408.Outcometree.out_variant -> Ast_409.Outcometree.out_variant =
function
| Ast_408.Outcometree.Ovar_fields x0 ->
Ast_409.Outcometree.Ovar_fields
(List.map
(fun x ->
let (x0, x1, x2) = x in (x0, x1, (List.map copy_out_type x2)))
x0)
| Ast_408.Outcometree.Ovar_typ x0 ->
Ast_409.Outcometree.Ovar_typ (copy_out_type x0)
and copy_out_value :
Ast_408.Outcometree.out_value -> Ast_409.Outcometree.out_value =
function
| Ast_408.Outcometree.Oval_array x0 ->
Ast_409.Outcometree.Oval_array (List.map copy_out_value x0)
| Ast_408.Outcometree.Oval_char x0 -> Ast_409.Outcometree.Oval_char x0
| Ast_408.Outcometree.Oval_constr (x0, x1) ->
Ast_409.Outcometree.Oval_constr
((copy_out_ident x0), (List.map copy_out_value x1))
| Ast_408.Outcometree.Oval_ellipsis -> Ast_409.Outcometree.Oval_ellipsis
| Ast_408.Outcometree.Oval_float x0 -> Ast_409.Outcometree.Oval_float x0
| Ast_408.Outcometree.Oval_int x0 -> Ast_409.Outcometree.Oval_int x0
| Ast_408.Outcometree.Oval_int32 x0 -> Ast_409.Outcometree.Oval_int32 x0
| Ast_408.Outcometree.Oval_int64 x0 -> Ast_409.Outcometree.Oval_int64 x0
| Ast_408.Outcometree.Oval_nativeint x0 ->
Ast_409.Outcometree.Oval_nativeint x0
| Ast_408.Outcometree.Oval_list x0 ->
Ast_409.Outcometree.Oval_list (List.map copy_out_value x0)
| Ast_408.Outcometree.Oval_printer x0 ->
Ast_409.Outcometree.Oval_printer x0
| Ast_408.Outcometree.Oval_record x0 ->
Ast_409.Outcometree.Oval_record
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_ident x0), (copy_out_value x1)))
x0)
| Ast_408.Outcometree.Oval_string (x0, x1, x2) ->
Ast_409.Outcometree.Oval_string (x0, x1, (copy_out_string x2))
| Ast_408.Outcometree.Oval_stuff x0 -> Ast_409.Outcometree.Oval_stuff x0
| Ast_408.Outcometree.Oval_tuple x0 ->
Ast_409.Outcometree.Oval_tuple (List.map copy_out_value x0)
| Ast_408.Outcometree.Oval_variant (x0, x1) ->
Ast_409.Outcometree.Oval_variant (x0, (Option.map copy_out_value x1))
and copy_out_string :
Ast_408.Outcometree.out_string -> Ast_409.Outcometree.out_string =
function
| Ast_408.Outcometree.Ostr_string -> Ast_409.Outcometree.Ostr_string
| Ast_408.Outcometree.Ostr_bytes -> Ast_409.Outcometree.Ostr_bytes
and copy_out_ident :
Ast_408.Outcometree.out_ident -> Ast_409.Outcometree.out_ident =
function
| Ast_408.Outcometree.Oide_apply (x0, x1) ->
Ast_409.Outcometree.Oide_apply
((copy_out_ident x0), (copy_out_ident x1))
| Ast_408.Outcometree.Oide_dot (x0, x1) ->
Ast_409.Outcometree.Oide_dot ((copy_out_ident x0), x1)
| Ast_408.Outcometree.Oide_ident x0 ->
Ast_409.Outcometree.Oide_ident (copy_out_name x0)
and copy_out_name :
Ast_408.Outcometree.out_name -> Ast_409.Outcometree.out_name =
fun { Ast_408.Outcometree.printed_name = printed_name } ->
{ Ast_409.Outcometree.printed_name = printed_name }
================================================
FILE: src/vendored-omp/src/migrate_parsetree_409_408.ml
================================================
(**************************************************************************)
(* *)
(* OCaml Migrate Parsetree *)
(* *)
(* Frédéric Bour *)
(* *)
(* Copyright 2017 Institut National de Recherche en Informatique et *)
(* en Automatique (INRIA). *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
include Migrate_parsetree_409_408_migrate
================================================
FILE: src/vendored-omp/src/migrate_parsetree_409_408_migrate.ml
================================================
open Stdlib0
module From = Ast_409
module To = Ast_408
let rec copy_out_type_extension :
Ast_409.Outcometree.out_type_extension ->
Ast_408.Outcometree.out_type_extension
=
fun
{ Ast_409.Outcometree.otyext_name = otyext_name;
Ast_409.Outcometree.otyext_params = otyext_params;
Ast_409.Outcometree.otyext_constructors = otyext_constructors;
Ast_409.Outcometree.otyext_private = otyext_private }
->
{
Ast_408.Outcometree.otyext_name = otyext_name;
Ast_408.Outcometree.otyext_params =
(List.map (fun x -> x) otyext_params);
Ast_408.Outcometree.otyext_constructors =
(List.map
(fun x ->
let (x0, x1, x2) = x in
(x0, (List.map copy_out_type x1),
(Option.map copy_out_type x2))) otyext_constructors);
Ast_408.Outcometree.otyext_private = (copy_private_flag otyext_private)
}
and copy_out_phrase :
Ast_409.Outcometree.out_phrase -> Ast_408.Outcometree.out_phrase =
function
| Ast_409.Outcometree.Ophr_eval (x0, x1) ->
Ast_408.Outcometree.Ophr_eval ((copy_out_value x0), (copy_out_type x1))
| Ast_409.Outcometree.Ophr_signature x0 ->
Ast_408.Outcometree.Ophr_signature
(List.map
(fun x ->
let (x0, x1) = x in
((copy_out_sig_item x0), (Option.map copy_out_value x1))) x0)
| Ast_409.Outcometree.Ophr_exception x0 ->
Ast_408.Outcometree.Ophr_exception
(let (x0, x1) = x0 in (x0, (copy_out_value x1)))
and copy_out_sig_item :
Ast_409.Outcometree.out_sig_item -> Ast_408.Outcometree.out_sig_item =
function
| Ast_409.Outcometree.Osig_class (x0, x1, x2, x3, x4) ->
Ast_408.Outcometree.Osig_class
(x0, x1,
(List.map
(fun x ->
let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) x2),
(copy_out_class_type x3), (copy_out_rec_status x4))
| Ast_409.Outcometree.Osig_class_type (x0, x1, x2, x3, x4) ->
Ast_408.Outcometree.Osig_class_type
(x0, x1,
(List.map
(fun x ->
let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) x2),
(copy_out_class_type x3), (copy_out_rec_status x4))
| Ast_409.Outcometree.Osig_typext (x0, x1) ->
Ast_408.Outcometree.Osig_typext
((copy_out_extension_constructor x0), (copy_out_ext_status x1))
| Ast_409.Outcometree.Osig_modtype (x0, x1) ->
Ast_408.Outcometree.Osig_modtype (x0, (copy_out_module_type x1))
| Ast_409.Outcometree.Osig_module (x0, x1, x2) ->
Ast_408.Outcometree.Osig_module
(x0, (copy_out_module_type x1), (copy_out_rec_status x2))
| Ast_409.Outcometree.Osig_type (x0, x1) ->
Ast_408.Outcometree.Osig_type
((copy_out_type_decl x0), (copy_out_rec_status x1))
| Ast_409.Outcometree.Osig_value x0 ->
Ast_408.Outcometree.Osig_value (copy_out_val_decl x0)
| Ast_409.Outcometree.Osig_ellipsis -> Ast_408.Outcometree.Osig_ellipsis
and copy_out_val_decl :
Ast_409.Outcometree.out_val_decl -> Ast_408.Outcometree.out_val_decl =
fun
{ Ast_409.Outcometree.oval_name = oval_name;
Ast_409.Outcometree.oval_type = oval_type;
Ast_409.Outcometree.oval_prims = oval_prims;
Ast_409.Outcometree.oval_attributes = oval_attributes }
->
{
Ast_408.Outcometree.oval_name = oval_name;
Ast_408.Outcometree.oval_type = (copy_out_type oval_type);
Ast_408.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims);
Ast_408.Outcometree.oval_attributes =
(List.map copy_out_attribute oval_attributes)
}
and copy_out_type_decl :
Ast_409.Outcometree.out_type_decl -> Ast_408.Outcometree.out_type_decl =
fun
{ Ast_409.Outcometree.otype_name = otype_name;
Ast_409.Outcometree.otype_params = otype_params;
Ast_409.Outcometree.otype_type = otype_type;
Ast_409.Outcometree.otype_private = otype_private;
Ast_409.Outcometree.otype_immediate = otype_immediate;
Ast_409.Outcometree.otype_unboxed = otype_unboxed;
Ast_409.Outcometree.otype_cstrs = otype_cstrs }
->
{
Ast_408.Outcometree.otype_name = otype_name;
Ast_408.Outcometree.otype_params =
(List.map
(fun x ->
let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1))))
otype_params);
Ast_408.Outcometree.otype_type = (copy_out_type otype_type);
Ast_408.Outcometree.otype_private = (copy_private_flag otype_private);
Ast_408.Outcometree.otype_immediate = otype_immediate;
Ast_408.Outcometree.otype_unboxed = otype_unboxed;
Ast_408.Outcometree.otype_cstrs =
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_type x0), (copy_out_type x1)))
otype_cstrs)
}
and copy_out_module_type :
Ast_409.Outcometree.out_module_type -> Ast_408.Outcometree.out_module_type
=
function
| Ast_409.Outcometree.Omty_abstract -> Ast_408.Outcometree.Omty_abstract
| Ast_409.Outcometree.Omty_functor (x0, x1, x2) ->
Ast_408.Outcometree.Omty_functor
(x0, (Option.map copy_out_module_type x1), (copy_out_module_type x2))
| Ast_409.Outcometree.Omty_ident x0 ->
Ast_408.Outcometree.Omty_ident (copy_out_ident x0)
| Ast_409.Outcometree.Omty_signature x0 ->
Ast_408.Outcometree.Omty_signature (List.map copy_out_sig_item x0)
| Ast_409.Outcometree.Omty_alias x0 ->
Ast_408.Outcometree.Omty_alias (copy_out_ident x0)
and copy_out_ext_status :
Ast_409.Outcometree.out_ext_status -> Ast_408.Outcometree.out_ext_status =
function
| Ast_409.Outcometree.Oext_first -> Ast_408.Outcometree.Oext_first
| Ast_409.Outcometree.Oext_next -> Ast_408.Outcometree.Oext_next
| Ast_409.Outcometree.Oext_exception -> Ast_408.Outcometree.Oext_exception
and copy_out_extension_constructor :
Ast_409.Outcometree.out_extension_constructor ->
Ast_408.Outcometree.out_extension_constructor
=
fun
{ Ast_409.Outcometree.oext_name = oext_name;
Ast_409.Outcometree.oext_type_name = oext_type_name;
Ast_409.Outcometree.oext_type_params = oext_type_params;
Ast_409.Outcometree.oext_args = oext_args;
Ast_409.Outcometree.oext_ret_type = oext_ret_type;
Ast_409.Outcometree.oext_private = oext_private }
->
{
Ast_408.Outcometree.oext_name = oext_name;
Ast_408.Outcometree.oext_type_name = oext_type_name;
Ast_408.Outcometree.oext_type_params =
(List.map (fun x -> x) oext_type_params);
Ast_408.Outcometree.oext_args = (List.map copy_out_type oext_args);
Ast_408.Outcometree.oext_ret_type =
(Option.map copy_out_type oext_ret_type);
Ast_408.Outcometree.oext_private = (copy_private_flag oext_private)
}
and copy_private_flag :
Ast_409.Asttypes.private_flag -> Ast_408.Asttypes.private_flag =
function
| Ast_409.Asttypes.Private -> Ast_408.Asttypes.Private
| Ast_409.Asttypes.Public -> Ast_408.Asttypes.Public
and copy_out_rec_status :
Ast_409.Outcometree.out_rec_status -> Ast_408.Outcometree.out_rec_status =
function
| Ast_409.Outcometree.Orec_not -> Ast_408.Outcometree.Orec_not
| Ast_409.Outcometree.Orec_first -> Ast_408.Outcometree.Orec_first
| Ast_409.Outcometree.Orec_next -> Ast_408.Outcometree.Orec_next
and copy_out_class_type :
Ast_409.Outcometree.out_class_type -> Ast_408.Outcometree.out_class_type =
function
| Ast_409.Outcometree.Octy_constr (x0, x1) ->
Ast_408.Outcometree.Octy_constr
((copy_out_ident x0), (List.map copy_out_type x1))
| Ast_409.Outcometree.Octy_arrow (x0, x1, x2) ->
Ast_408.Outcometree.Octy_arrow
(x0, (copy_out_type x1), (copy_out_class_type x2))
| Ast_409.Outcometree.Octy_signature (x0, x1) ->
Ast_408.Outcometree.Octy_signature
((Option.map copy_out_type x0),
(List.map copy_out_class_sig_item x1))
and copy_out_class_sig_item :
Ast_409.Outcometree.out_class_sig_item ->
Ast_408.Outcometree.out_class_sig_item
=
function
| Ast_409.Outcometree.Ocsg_constraint (x0, x1) ->
Ast_408.Outcometree.Ocsg_constraint
((copy_out_type x0), (copy_out_type x1))
| Ast_409.Outcometree.Ocsg_method (x0, x1, x2, x3) ->
Ast_408.Outcometree.Ocsg_method (x0, x1, x2, (copy_out_type x3))
| Ast_409.Outcometree.Ocsg_value (x0, x1, x2, x3) ->
Ast_408.Outcometree.Ocsg_value (x0, x1, x2, (copy_out_type x3))
and copy_out_type :
Ast_409.Outcometree.out_type -> Ast_408.Outcometree.out_type =
function
| Ast_409.Outcometree.Otyp_abstract -> Ast_408.Outcometree.Otyp_abstract
| Ast_409.Outcometree.Otyp_open -> Ast_408.Outcometree.Otyp_open
| Ast_409.Outcometree.Otyp_alias (x0, x1) ->
Ast_408.Outcometree.Otyp_alias ((copy_out_type x0), x1)
| Ast_409.Outcometree.Otyp_arrow (x0, x1, x2) ->
Ast_408.Outcometree.Otyp_arrow
(x0, (copy_out_type x1), (copy_out_type x2))
| Ast_409.Outcometree.Otyp_class (x0, x1, x2) ->
Ast_408.Outcometree.Otyp_class
(x0, (copy_out_ident x1), (List.map copy_out_type x2))
| Ast_409.Outcometree.Otyp_constr (x0, x1) ->
Ast_408.Outcometree.Otyp_constr
((copy_out_ident x0), (List.map copy_out_type x1))
| Ast_409.Outcometree.Otyp_manifest (x0, x1) ->
Ast_408.Outcometree.Otyp_manifest
((copy_out_type x0), (copy_out_type x1))
| Ast_409.Outcometree.Otyp_object (x0, x1) ->
Ast_408.Outcometree.Otyp_object
((List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1))) x0),
(Option.map (fun x -> x) x1))
| Ast_409.Outcometree.Otyp_record x0 ->
Ast_408.Outcometree.Otyp_record
(List.map
(fun x -> let (x0, x1, x2) = x in (x0, x1, (copy_out_type x2))) x0)
| Ast_409.Outcometree.Otyp_stuff x0 -> Ast_408.Outcometree.Otyp_stuff x0
| Ast_409.Outcometree.Otyp_sum x0 ->
Ast_408.Outcometree.Otyp_sum
(List.map
(fun x ->
let (x0, x1, x2) = x in
(x0, (List.map copy_out_type x1),
(Option.map copy_out_type x2))) x0)
| Ast_409.Outcometree.Otyp_tuple x0 ->
Ast_408.Outcometree.Otyp_tuple (List.map copy_out_type x0)
| Ast_409.Outcometree.Otyp_var (x0, x1) ->
Ast_408.Outcometree.Otyp_var (x0, x1)
| Ast_409.Outcometree.Otyp_variant (x0, x1, x2, x3) ->
Ast_408.Outcometree.Otyp_variant
(x0, (copy_out_variant x1), x2,
(Option.map (fun x -> List.map (fun x -> x) x) x3))
| Ast_409.Outcometree.Otyp_poly (x0, x1) ->
Ast_408.Outcometree.Otyp_poly
((List.map (fun x -> x) x0), (copy_out_type x1))
| Ast_409.Outcometree.Otyp_module (x0, x1, x2) ->
Ast_408.Outcometree.Otyp_module
((copy_out_ident x0), (List.map (fun x -> x) x1),
(List.map copy_out_type x2))
| Ast_409.Outcometree.Otyp_attribute (x0, x1) ->
Ast_408.Outcometree.Otyp_attribute
((copy_out_type x0), (copy_out_attribute x1))
and copy_out_attribute :
Ast_409.Outcometree.out_attribute -> Ast_408.Outcometree.out_attribute =
fun { Ast_409.Outcometree.oattr_name = oattr_name } ->
{ Ast_408.Outcometree.oattr_name = oattr_name }
and copy_out_variant :
Ast_409.Outcometree.out_variant -> Ast_408.Outcometree.out_variant =
function
| Ast_409.Outcometree.Ovar_fields x0 ->
Ast_408.Outcometree.Ovar_fields
(List.map
(fun x ->
let (x0, x1, x2) = x in (x0, x1, (List.map copy_out_type x2)))
x0)
| Ast_409.Outcometree.Ovar_typ x0 ->
Ast_408.Outcometree.Ovar_typ (copy_out_type x0)
and copy_out_value :
Ast_409.Outcometree.out_value -> Ast_408.Outcometree.out_value =
function
| Ast_409.Outcometree.Oval_array x0 ->
Ast_408.Outcometree.Oval_array (List.map copy_out_value x0)
| Ast_409.Outcometree.Oval_char x0 -> Ast_408.Outcometree.Oval_char x0
| Ast_409.Outcometree.Oval_constr (x0, x1) ->
Ast_408.Outcometree.Oval_constr
((copy_out_ident x0), (List.map copy_out_value x1))
| Ast_409.Outcometree.Oval_ellipsis -> Ast_408.Outcometree.Oval_ellipsis
| Ast_409.Outcometree.Oval_float x0 -> Ast_408.Outcometree.Oval_float x0
| Ast_409.Outcometree.Oval_int x0 -> Ast_408.Outcometree.Oval_int x0
| Ast_409.Outcometree.Oval_int32 x0 -> Ast_408.Outcometree.Oval_int32 x0
| Ast_409.Outcometree.Oval_int64 x0 -> Ast_408.Outcometree.Oval_int64 x0
| Ast_409.Outcometree.Oval_nativeint x0 ->
Ast_408.Outcometree.Oval_nativeint x0
| Ast_409.Outcometree.Oval_list x0 ->
Ast_408.Outcometree.Oval_list (List.map copy_out_value x0)
| Ast_409.Outcometree.Oval_printer x0 ->
Ast_408.Outcometree.Oval_printer x0
| Ast_409.Outcometree.Oval_record x0 ->
Ast_408.Outcometree.Oval_record
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_ident x0), (copy_out_value x1)))
x0)
| Ast_409.Outcometree.Oval_string (x0, x1, x2) ->
Ast_408.Outcometree.Oval_string (x0, x1, (copy_out_string x2))
| Ast_409.Outcometree.Oval_stuff x0 -> Ast_408.Outcometree.Oval_stuff x0
| Ast_409.Outcometree.Oval_tuple x0 ->
Ast_408.Outcometree.Oval_tuple (List.map copy_out_value x0)
| Ast_409.Outcometree.Oval_variant (x0, x1) ->
Ast_408.Outcometree.Oval_variant (x0, (Option.map copy_out_value x1))
and copy_out_string :
Ast_409.Outcometree.out_string -> Ast_408.Outcometree.out_string =
function
| Ast_409.Outcometree.Ostr_string -> Ast_408.Outcometree.Ostr_string
| Ast_409.Outcometree.Ostr_bytes -> Ast_408.Outcometree.Ostr_bytes
and copy_out_ident :
Ast_409.Outcometree.out_ident -> Ast_408.Outcometree.out_ident =
function
| Ast_409.Outcometree.Oide_apply (x0, x1) ->
Ast_408.Outcometree.Oide_apply
((copy_out_ident x0), (copy_out_ident x1))
| Ast_409.Outcometree.Oide_dot (x0, x1) ->
Ast_408.Outcometree.Oide_dot ((copy_out_ident x0), x1)
| Ast_409.Outcometree.Oide_ident x0 ->
Ast_408.Outcometree.Oide_ident (copy_out_name x0)
and copy_out_name :
Ast_409.Outcometree.out_name -> Ast_408.Outcometree.out_name =
fun { Ast_409.Outcometree.printed_name = printed_name } ->
{ Ast_408.Outcometree.printed_name = printed_name }
================================================
FILE: src/vendored-omp/src/migrate_parsetree_409_410.ml
================================================
(**************************************************************************)
(* *)
(* OCaml Migrate Parsetree *)
(* *)
(* Frédéric Bour *)
(* *)
(* Copyright 2017 Institut National de Recherche en Informatique et *)
(* en Automatique (INRIA). *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
include Migrate_parsetree_409_410_migrate
================================================
FILE: src/vendored-omp/src/migrate_parsetree_409_410_migrate.ml
================================================
open Stdlib0
module From = Ast_409
module To = Ast_410
let rec copy_out_type_extension :
Ast_409.Outcometree.out_type_extension ->
Ast_410.Outcometree.out_type_extension
=
fun
{ Ast_409.Outcometree.otyext_name = otyext_name;
Ast_409.Outcometree.otyext_params = otyext_params;
Ast_409.Outcometree.otyext_constructors = otyext_constructors;
Ast_409.Outcometree.otyext_private = otyext_private }
->
{
Ast_410.Outcometree.otyext_name = otyext_name;
Ast_410.Outcometree.otyext_params =
(List.map (fun x -> x) otyext_params);
Ast_410.Outcometree.otyext_constructors =
(List.map
(fun x ->
let (x0, x1, x2) = x in
(x0, (List.map copy_out_type x1),
(Option.map copy_out_type x2))) otyext_constructors);
Ast_410.Outcometree.otyext_private = (copy_private_flag otyext_private)
}
and copy_out_phrase :
Ast_409.Outcometree.out_phrase -> Ast_410.Outcometree.out_phrase =
function
| Ast_409.Outcometree.Ophr_eval (x0, x1) ->
Ast_410.Outcometree.Ophr_eval ((copy_out_value x0), (copy_out_type x1))
| Ast_409.Outcometree.Ophr_signature x0 ->
Ast_410.Outcometree.Ophr_signature
(List.map
(fun x ->
let (x0, x1) = x in
((copy_out_sig_item x0), (Option.map copy_out_value x1))) x0)
| Ast_409.Outcometree.Ophr_exception x0 ->
Ast_410.Outcometree.Ophr_exception
(let (x0, x1) = x0 in (x0, (copy_out_value x1)))
and copy_out_sig_item :
Ast_409.Outcometree.out_sig_item -> Ast_410.Outcometree.out_sig_item =
function
| Ast_409.Outcometree.Osig_class (x0, x1, x2, x3, x4) ->
Ast_410.Outcometree.Osig_class
(x0, x1,
(List.map
(fun x ->
let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) x2),
(copy_out_class_type x3), (copy_out_rec_status x4))
| Ast_409.Outcometree.Osig_class_type (x0, x1, x2, x3, x4) ->
Ast_410.Outcometree.Osig_class_type
(x0, x1,
(List.map
(fun x ->
let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) x2),
(copy_out_class_type x3), (copy_out_rec_status x4))
| Ast_409.Outcometree.Osig_typext (x0, x1) ->
Ast_410.Outcometree.Osig_typext
((copy_out_extension_constructor x0), (copy_out_ext_status x1))
| Ast_409.Outcometree.Osig_modtype (x0, x1) ->
Ast_410.Outcometree.Osig_modtype (x0, (copy_out_module_type x1))
| Ast_409.Outcometree.Osig_module (x0, x1, x2) ->
Ast_410.Outcometree.Osig_module
(x0, (copy_out_module_type x1), (copy_out_rec_status x2))
| Ast_409.Outcometree.Osig_type (x0, x1) ->
Ast_410.Outcometree.Osig_type
((copy_out_type_decl x0), (copy_out_rec_status x1))
| Ast_409.Outcometree.Osig_value x0 ->
Ast_410.Outcometree.Osig_value (copy_out_val_decl x0)
| Ast_409.Outcometree.Osig_ellipsis -> Ast_410.Outcometree.Osig_ellipsis
and copy_out_val_decl :
Ast_409.Outcometree.out_val_decl -> Ast_410.Outcometree.out_val_decl =
fun
{ Ast_409.Outcometree.oval_name = oval_name;
Ast_409.Outcometree.oval_type = oval_type;
Ast_409.Outcometree.oval_prims = oval_prims;
Ast_409.Outcometree.oval_attributes = oval_attributes }
->
{
Ast_410.Outcometree.oval_name = oval_name;
Ast_410.Outcometree.oval_type = (copy_out_type oval_type);
Ast_410.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims);
Ast_410.Outcometree.oval_attributes =
(List.map copy_out_attribute oval_attributes)
}
and copy_out_type_decl :
Ast_409.Outcometree.out_type_decl -> Ast_410.Outcometree.out_type_decl =
fun
{ Ast_409.Outcometree.otype_name = otype_name;
Ast_409.Outcometree.otype_params = otype_params;
Ast_409.Outcometree.otype_type = otype_type;
Ast_409.Outcometree.otype_private = otype_private;
Ast_409.Outcometree.otype_immediate = otype_immediate;
Ast_409.Outcometree.otype_unboxed = otype_unboxed;
Ast_409.Outcometree.otype_cstrs = otype_cstrs }
->
{
Ast_410.Outcometree.otype_name = otype_name;
Ast_410.Outcometree.otype_params =
(List.map
(fun x ->
let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1))))
otype_params);
Ast_410.Outcometree.otype_type = (copy_out_type otype_type);
Ast_410.Outcometree.otype_private = (copy_private_flag otype_private);
Ast_410.Outcometree.otype_immediate = (if otype_immediate then Always else Unknown);
Ast_410.Outcometree.otype_unboxed = otype_unboxed;
Ast_410.Outcometree.otype_cstrs =
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_type x0), (copy_out_type x1)))
otype_cstrs)
}
and copy_out_module_type :
Ast_409.Outcometree.out_module_type -> Ast_410.Outcometree.out_module_type
=
function
| Ast_409.Outcometree.Omty_abstract -> Ast_410.Outcometree.Omty_abstract
| Ast_409.Outcometree.Omty_functor (x0, x1, x2) ->
Ast_410.Outcometree.Omty_functor
((match x0, x1 with
| "*", None -> None
| "_", Some mt -> Some (None, copy_out_module_type mt)
| s, Some mt -> Some (Some s, copy_out_module_type mt)
|_ -> assert false),
copy_out_module_type x2)
| Ast_409.Outcometree.Omty_ident x0 ->
Ast_410.Outcometree.Omty_ident (copy_out_ident x0)
| Ast_409.Outcometree.Omty_signature x0 ->
Ast_410.Outcometree.Omty_signature (List.map copy_out_sig_item x0)
| Ast_409.Outcometree.Omty_alias x0 ->
Ast_410.Outcometree.Omty_alias (copy_out_ident x0)
and copy_out_ext_status :
Ast_409.Outcometree.out_ext_status -> Ast_410.Outcometree.out_ext_status =
function
| Ast_409.Outcometree.Oext_first -> Ast_410.Outcometree.Oext_first
| Ast_409.Outcometree.Oext_next -> Ast_410.Outcometree.Oext_next
| Ast_409.Outcometree.Oext_exception -> Ast_410.Outcometree.Oext_exception
and copy_out_extension_constructor :
Ast_409.Outcometree.out_extension_constructor ->
Ast_410.Outcometree.out_extension_constructor
=
fun
{ Ast_409.Outcometree.oext_name = oext_name;
Ast_409.Outcometree.oext_type_name = oext_type_name;
Ast_409.Outcometree.oext_type_params = oext_type_params;
Ast_409.Outcometree.oext_args = oext_args;
Ast_409.Outcometree.oext_ret_type = oext_ret_type;
Ast_409.Outcometree.oext_private = oext_private }
->
{
Ast_410.Outcometree.oext_name = oext_name;
Ast_410.Outcometree.oext_type_name = oext_type_name;
Ast_410.Outcometree.oext_type_params =
(List.map (fun x -> x) oext_type_params);
Ast_410.Outcometree.oext_args = (List.map copy_out_type oext_args);
Ast_410.Outcometree.oext_ret_type =
(Option.map copy_out_type oext_ret_type);
Ast_410.Outcometree.oext_private = (copy_private_flag oext_private)
}
and copy_private_flag :
Ast_409.Asttypes.private_flag -> Ast_410.Asttypes.private_flag =
function
| Ast_409.Asttypes.Private -> Ast_410.Asttypes.Private
| Ast_409.Asttypes.Public -> Ast_410.Asttypes.Public
and copy_out_rec_status :
Ast_409.Outcometree.out_rec_status -> Ast_410.Outcometree.out_rec_status =
function
| Ast_409.Outcometree.Orec_not -> Ast_410.Outcometree.Orec_not
| Ast_409.Outcometree.Orec_first -> Ast_410.Outcometree.Orec_first
| Ast_409.Outcometree.Orec_next -> Ast_410.Outcometree.Orec_next
and copy_out_class_type :
Ast_409.Outcometree.out_class_type -> Ast_410.Outcometree.out_class_type =
function
| Ast_409.Outcometree.Octy_constr (x0, x1) ->
Ast_410.Outcometree.Octy_constr
((copy_out_ident x0), (List.map copy_out_type x1))
| Ast_409.Outcometree.Octy_arrow (x0, x1, x2) ->
Ast_410.Outcometree.Octy_arrow
(x0, (copy_out_type x1), (copy_out_class_type x2))
| Ast_409.Outcometree.Octy_signature (x0, x1) ->
Ast_410.Outcometree.Octy_signature
((Option.map copy_out_type x0),
(List.map copy_out_class_sig_item x1))
and copy_out_class_sig_item :
Ast_409.Outcometree.out_class_sig_item ->
Ast_410.Outcometree.out_class_sig_item
=
function
| Ast_409.Outcometree.Ocsg_constraint (x0, x1) ->
Ast_410.Outcometree.Ocsg_constraint
((copy_out_type x0), (copy_out_type x1))
| Ast_409.Outcometree.Ocsg_method (x0, x1, x2, x3) ->
Ast_410.Outcometree.Ocsg_method (x0, x1, x2, (copy_out_type x3))
| Ast_409.Outcometree.Ocsg_value (x0, x1, x2, x3) ->
Ast_410.Outcometree.Ocsg_value (x0, x1, x2, (copy_out_type x3))
and copy_out_type :
Ast_409.Outcometree.out_type -> Ast_410.Outcometree.out_type =
function
| Ast_409.Outcometree.Otyp_abstract -> Ast_410.Outcometree.Otyp_abstract
| Ast_409.Outcometree.Otyp_open -> Ast_410.Outcometree.Otyp_open
| Ast_409.Outcometree.Otyp_alias (x0, x1) ->
Ast_410.Outcometree.Otyp_alias ((copy_out_type x0), x1)
| Ast_409.Outcometree.Otyp_arrow (x0, x1, x2) ->
Ast_410.Outcometree.Otyp_arrow
(x0, (copy_out_type x1), (copy_out_type x2))
| Ast_409.Outcometree.Otyp_class (x0, x1, x2) ->
Ast_410.Outcometree.Otyp_class
(x0, (copy_out_ident x1), (List.map copy_out_type x2))
| Ast_409.Outcometree.Otyp_constr (x0, x1) ->
Ast_410.Outcometree.Otyp_constr
((copy_out_ident x0), (List.map copy_out_type x1))
| Ast_409.Outcometree.Otyp_manifest (x0, x1) ->
Ast_410.Outcometree.Otyp_manifest
((copy_out_type x0), (copy_out_type x1))
| Ast_409.Outcometree.Otyp_object (x0, x1) ->
Ast_410.Outcometree.Otyp_object
((List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1))) x0),
(Option.map (fun x -> x) x1))
| Ast_409.Outcometree.Otyp_record x0 ->
Ast_410.Outcometree.Otyp_record
(List.map
(fun x -> let (x0, x1, x2) = x in (x0, x1, (copy_out_type x2))) x0)
| Ast_409.Outcometree.Otyp_stuff x0 -> Ast_410.Outcometree.Otyp_stuff x0
| Ast_409.Outcometree.Otyp_sum x0 ->
Ast_410.Outcometree.Otyp_sum
(List.map
(fun x ->
let (x0, x1, x2) = x in
(x0, (List.map copy_out_type x1),
(Option.map copy_out_type x2))) x0)
| Ast_409.Outcometree.Otyp_tuple x0 ->
Ast_410.Outcometree.Otyp_tuple (List.map copy_out_type x0)
| Ast_409.Outcometree.Otyp_var (x0, x1) ->
Ast_410.Outcometree.Otyp_var (x0, x1)
| Ast_409.Outcometree.Otyp_variant (x0, x1, x2, x3) ->
Ast_410.Outcometree.Otyp_variant
(x0, (copy_out_variant x1), x2,
(Option.map (fun x -> List.map (fun x -> x) x) x3))
| Ast_409.Outcometree.Otyp_poly (x0, x1) ->
Ast_410.Outcometree.Otyp_poly
((List.map (fun x -> x) x0), (copy_out_type x1))
| Ast_409.Outcometree.Otyp_module (x0, x1, x2) ->
Ast_410.Outcometree.Otyp_module
((copy_out_ident x0), (List.map (fun x -> x) x1),
(List.map copy_out_type x2))
| Ast_409.Outcometree.Otyp_attribute (x0, x1) ->
Ast_410.Outcometree.Otyp_attribute
((copy_out_type x0), (copy_out_attribute x1))
and copy_out_attribute :
Ast_409.Outcometree.out_attribute -> Ast_410.Outcometree.out_attribute =
fun { Ast_409.Outcometree.oattr_name = oattr_name } ->
{ Ast_410.Outcometree.oattr_name = oattr_name }
and copy_out_variant :
Ast_409.Outcometree.out_variant -> Ast_410.Outcometree.out_variant =
function
| Ast_409.Outcometree.Ovar_fields x0 ->
Ast_410.Outcometree.Ovar_fields
(List.map
(fun x ->
let (x0, x1, x2) = x in (x0, x1, (List.map copy_out_type x2)))
x0)
| Ast_409.Outcometree.Ovar_typ x0 ->
Ast_410.Outcometree.Ovar_typ (copy_out_type x0)
and copy_out_value :
Ast_409.Outcometree.out_value -> Ast_410.Outcometree.out_value =
function
| Ast_409.Outcometree.Oval_array x0 ->
Ast_410.Outcometree.Oval_array (List.map copy_out_value x0)
| Ast_409.Outcometree.Oval_char x0 -> Ast_410.Outcometree.Oval_char x0
| Ast_409.Outcometree.Oval_constr (x0, x1) ->
Ast_410.Outcometree.Oval_constr
((copy_out_ident x0), (List.map copy_out_value x1))
| Ast_409.Outcometree.Oval_ellipsis -> Ast_410.Outcometree.Oval_ellipsis
| Ast_409.Outcometree.Oval_float x0 -> Ast_410.Outcometree.Oval_float x0
| Ast_409.Outcometree.Oval_int x0 -> Ast_410.Outcometree.Oval_int x0
| Ast_409.Outcometree.Oval_int32 x0 -> Ast_410.Outcometree.Oval_int32 x0
| Ast_409.Outcometree.Oval_int64 x0 -> Ast_410.Outcometree.Oval_int64 x0
| Ast_409.Outcometree.Oval_nativeint x0 ->
Ast_410.Outcometree.Oval_nativeint x0
| Ast_409.Outcometree.Oval_list x0 ->
Ast_410.Outcometree.Oval_list (List.map copy_out_value x0)
| Ast_409.Outcometree.Oval_printer x0 ->
Ast_410.Outcometree.Oval_printer x0
| Ast_409.Outcometree.Oval_record x0 ->
Ast_410.Outcometree.Oval_record
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_ident x0), (copy_out_value x1)))
x0)
| Ast_409.Outcometree.Oval_string (x0, x1, x2) ->
Ast_410.Outcometree.Oval_string (x0, x1, (copy_out_string x2))
| Ast_409.Outcometree.Oval_stuff x0 -> Ast_410.Outcometree.Oval_stuff x0
| Ast_409.Outcometree.Oval_tuple x0 ->
Ast_410.Outcometree.Oval_tuple (List.map copy_out_value x0)
| Ast_409.Outcometree.Oval_variant (x0, x1) ->
Ast_410.Outcometree.Oval_variant (x0, (Option.map copy_out_value x1))
and copy_out_string :
Ast_409.Outcometree.out_string -> Ast_410.Outcometree.out_string =
function
| Ast_409.Outcometree.Ostr_string -> Ast_410.Outcometree.Ostr_string
| Ast_409.Outcometree.Ostr_bytes -> Ast_410.Outcometree.Ostr_bytes
and copy_out_ident :
Ast_409.Outcometree.out_ident -> Ast_410.Outcometree.out_ident =
function
| Ast_409.Outcometree.Oide_apply (x0, x1) ->
Ast_410.Outcometree.Oide_apply
((copy_out_ident x0), (copy_out_ident x1))
| Ast_409.Outcometree.Oide_dot (x0, x1) ->
Ast_410.Outcometree.Oide_dot ((copy_out_ident x0), x1)
| Ast_409.Outcometree.Oide_ident x0 ->
Ast_410.Outcometree.Oide_ident (copy_out_name x0)
and copy_out_name :
Ast_409.Outcometree.out_name -> Ast_410.Outcometree.out_name =
fun { Ast_409.Outcometree.printed_name = printed_name } ->
{ Ast_410.Outcometree.printed_name = printed_name }
================================================
FILE: src/vendored-omp/src/migrate_parsetree_410_409.ml
================================================
(**************************************************************************)
(* *)
(* OCaml Migrate Parsetree *)
(* *)
(* Frédéric Bour *)
(* *)
(* Copyright 2017 Institut National de Recherche en Informatique et *)
(* en Automatique (INRIA). *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
include Migrate_parsetree_410_409_migrate
================================================
FILE: src/vendored-omp/src/migrate_parsetree_410_409_migrate.ml
================================================
open Stdlib0
module From = Ast_410
module To = Ast_409
module Def = Migrate_parsetree_def
let migration_error location feature =
raise (Def.Migration_error (feature, location))
let rec copy_out_type_extension :
Ast_410.Outcometree.out_type_extension ->
Ast_409.Outcometree.out_type_extension
=
fun
{ Ast_410.Outcometree.otyext_name = otyext_name;
Ast_410.Outcometree.otyext_params = otyext_params;
Ast_410.Outcometree.otyext_constructors = otyext_constructors;
Ast_410.Outcometree.otyext_private = otyext_private }
->
{
Ast_409.Outcometree.otyext_name = otyext_name;
Ast_409.Outcometree.otyext_params =
(List.map (fun x -> x) otyext_params);
Ast_409.Outcometree.otyext_constructors =
(List.map
(fun x ->
let (x0, x1, x2) = x in
(x0, (List.map copy_out_type x1),
(Option.map copy_out_type x2))) otyext_constructors);
Ast_409.Outcometree.otyext_private = (copy_private_flag otyext_private)
}
and copy_out_phrase :
Ast_410.Outcometree.out_phrase -> Ast_409.Outcometree.out_phrase =
function
| Ast_410.Outcometree.Ophr_eval (x0, x1) ->
Ast_409.Outcometree.Ophr_eval ((copy_out_value x0), (copy_out_type x1))
| Ast_410.Outcometree.Ophr_signature x0 ->
Ast_409.Outcometree.Ophr_signature
(List.map
(fun x ->
let (x0, x1) = x in
((copy_out_sig_item x0), (Option.map copy_out_value x1))) x0)
| Ast_410.Outcometree.Ophr_exception x0 ->
Ast_409.Outcometree.Ophr_exception
(let (x0, x1) = x0 in (x0, (copy_out_value x1)))
and copy_out_sig_item :
Ast_410.Outcometree.out_sig_item -> Ast_409.Outcometree.out_sig_item =
function
| Ast_410.Outcometree.Osig_class (x0, x1, x2, x3, x4) ->
Ast_409.Outcometree.Osig_class
(x0, x1,
(List.map
(fun x ->
let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) x2),
(copy_out_class_type x3), (copy_out_rec_status x4))
| Ast_410.Outcometree.Osig_class_type (x0, x1, x2, x3, x4) ->
Ast_409.Outcometree.Osig_class_type
(x0, x1,
(List.map
(fun x ->
let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) x2),
(copy_out_class_type x3), (copy_out_rec_status x4))
| Ast_410.Outcometree.Osig_typext (x0, x1) ->
Ast_409.Outcometree.Osig_typext
((copy_out_extension_constructor x0), (copy_out_ext_status x1))
| Ast_410.Outcometree.Osig_modtype (x0, x1) ->
Ast_409.Outcometree.Osig_modtype (x0, (copy_out_module_type x1))
| Ast_410.Outcometree.Osig_module (x0, x1, x2) ->
Ast_409.Outcometree.Osig_module
(x0, (copy_out_module_type x1), (copy_out_rec_status x2))
| Ast_410.Outcometree.Osig_type (x0, x1) ->
Ast_409.Outcometree.Osig_type
((copy_out_type_decl x0), (copy_out_rec_status x1))
| Ast_410.Outcometree.Osig_value x0 ->
Ast_409.Outcometree.Osig_value (copy_out_val_decl x0)
| Ast_410.Outcometree.Osig_ellipsis -> Ast_409.Outcometree.Osig_ellipsis
and copy_out_val_decl :
Ast_410.Outcometree.out_val_decl -> Ast_409.Outcometree.out_val_decl =
fun
{ Ast_410.Outcometree.oval_name = oval_name;
Ast_410.Outcometree.oval_type = oval_type;
Ast_410.Outcometree.oval_prims = oval_prims;
Ast_410.Outcometree.oval_attributes = oval_attributes }
->
{
Ast_409.Outcometree.oval_name = oval_name;
Ast_409.Outcometree.oval_type = (copy_out_type oval_type);
Ast_409.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims);
Ast_409.Outcometree.oval_attributes =
(List.map copy_out_attribute oval_attributes)
}
and copy_out_type_decl :
Ast_410.Outcometree.out_type_decl -> Ast_409.Outcometree.out_type_decl =
fun
{ Ast_410.Outcometree.otype_name = otype_name;
Ast_410.Outcometree.otype_params = otype_params;
Ast_410.Outcometree.otype_type = otype_type;
Ast_410.Outcometree.otype_private = otype_private;
Ast_410.Outcometree.otype_immediate = otype_immediate;
Ast_410.Outcometree.otype_unboxed = otype_unboxed;
Ast_410.Outcometree.otype_cstrs = otype_cstrs }
->
{
Ast_409.Outcometree.otype_name = otype_name;
Ast_409.Outcometree.otype_params =
(List.map
(fun x ->
let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1))))
otype_params);
Ast_409.Outcometree.otype_type = (copy_out_type otype_type);
Ast_409.Outcometree.otype_private = (copy_private_flag otype_private);
Ast_409.Outcometree.otype_immediate =
(copy_Type_immediacy_t otype_immediate);
Ast_409.Outcometree.otype_unboxed = otype_unboxed;
Ast_409.Outcometree.otype_cstrs =
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_type x0), (copy_out_type x1)))
otype_cstrs)
}
and copy_Type_immediacy_t :
Ast_410.Type_immediacy.t -> bool =
function
| Ast_410.Type_immediacy.Unknown -> false
| Ast_410.Type_immediacy.Always -> true
| Ast_410.Type_immediacy.Always_on_64bits -> migration_error Location.none Immediate64
and copy_out_module_type :
Ast_410.Outcometree.out_module_type -> Ast_409.Outcometree.out_module_type
=
function
| Ast_410.Outcometree.Omty_abstract -> Ast_409.Outcometree.Omty_abstract
| Ast_410.Outcometree.Omty_functor (x0, x1) ->
let name, mt =
match x0 with
| None -> "*", None
| Some (None, mt) -> "_", Some (copy_out_module_type mt)
| Some (Some s, mt) -> s, Some (copy_out_module_type mt)
in
Ast_409.Outcometree.Omty_functor
(name, mt, copy_out_module_type x1)
| Ast_410.Outcometree.Omty_ident x0 ->
Ast_409.Outcometree.Omty_ident (copy_out_ident x0)
| Ast_410.Outcometree.Omty_signature x0 ->
Ast_409.Outcometree.Omty_signature (List.map copy_out_sig_item x0)
| Ast_410.Outcometree.Omty_alias x0 ->
Ast_409.Outcometree.Omty_alias (copy_out_ident x0)
and copy_out_ext_status :
Ast_410.Outcometree.out_ext_status -> Ast_409.Outcometree.out_ext_status =
function
| Ast_410.Outcometree.Oext_first -> Ast_409.Outcometree.Oext_first
| Ast_410.Outcometree.Oext_next -> Ast_409.Outcometree.Oext_next
| Ast_410.Outcometree.Oext_exception -> Ast_409.Outcometree.Oext_exception
and copy_out_extension_constructor :
Ast_410.Outcometree.out_extension_constructor ->
Ast_409.Outcometree.out_extension_constructor
=
fun
{ Ast_410.Outcometree.oext_name = oext_name;
Ast_410.Outcometree.oext_type_name = oext_type_name;
Ast_410.Outcometree.oext_type_params = oext_type_params;
Ast_410.Outcometree.oext_args = oext_args;
Ast_410.Outcometree.oext_ret_type = oext_ret_type;
Ast_410.Outcometree.oext_private = oext_private }
->
{
Ast_409.Outcometree.oext_name = oext_name;
Ast_409.Outcometree.oext_type_name = oext_type_name;
Ast_409.Outcometree.oext_type_params =
(List.map (fun x -> x) oext_type_params);
Ast_409.Outcometree.oext_args = (List.map copy_out_type oext_args);
Ast_409.Outcometree.oext_ret_type =
(Option.map copy_out_type oext_ret_type);
Ast_409.Outcometree.oext_private = (copy_private_flag oext_private)
}
and copy_private_flag :
Ast_410.Asttypes.private_flag -> Ast_409.Asttypes.private_flag =
function
| Ast_410.Asttypes.Private -> Ast_409.Asttypes.Private
| Ast_410.Asttypes.Public -> Ast_409.Asttypes.Public
and copy_out_rec_status :
Ast_410.Outcometree.out_rec_status -> Ast_409.Outcometree.out_rec_status =
function
| Ast_410.Outcometree.Orec_not -> Ast_409.Outcometree.Orec_not
| Ast_410.Outcometree.Orec_first -> Ast_409.Outcometree.Orec_first
| Ast_410.Outcometree.Orec_next -> Ast_409.Outcometree.Orec_next
and copy_out_class_type :
Ast_410.Outcometree.out_class_type -> Ast_409.Outcometree.out_class_type =
function
| Ast_410.Outcometree.Octy_constr (x0, x1) ->
Ast_409.Outcometree.Octy_constr
((copy_out_ident x0), (List.map copy_out_type x1))
| Ast_410.Outcometree.Octy_arrow (x0, x1, x2) ->
Ast_409.Outcometree.Octy_arrow
(x0, (copy_out_type x1), (copy_out_class_type x2))
| Ast_410.Outcometree.Octy_signature (x0, x1) ->
Ast_409.Outcometree.Octy_signature
((Option.map copy_out_type x0),
(List.map copy_out_class_sig_item x1))
and copy_out_class_sig_item :
Ast_410.Outcometree.out_class_sig_item ->
Ast_409.Outcometree.out_class_sig_item
=
function
| Ast_410.Outcometree.Ocsg_constraint (x0, x1) ->
Ast_409.Outcometree.Ocsg_constraint
((copy_out_type x0), (copy_out_type x1))
| Ast_410.Outcometree.Ocsg_method (x0, x1, x2, x3) ->
Ast_409.Outcometree.Ocsg_method (x0, x1, x2, (copy_out_type x3))
| Ast_410.Outcometree.Ocsg_value (x0, x1, x2, x3) ->
Ast_409.Outcometree.Ocsg_value (x0, x1, x2, (copy_out_type x3))
and copy_out_type :
Ast_410.Outcometree.out_type -> Ast_409.Outcometree.out_type =
function
| Ast_410.Outcometree.Otyp_abstract -> Ast_409.Outcometree.Otyp_abstract
| Ast_410.Outcometree.Otyp_open -> Ast_409.Outcometree.Otyp_open
| Ast_410.Outcometree.Otyp_alias (x0, x1) ->
Ast_409.Outcometree.Otyp_alias ((copy_out_type x0), x1)
| Ast_410.Outcometree.Otyp_arrow (x0, x1, x2) ->
Ast_409.Outcometree.Otyp_arrow
(x0, (copy_out_type x1), (copy_out_type x2))
| Ast_410.Outcometree.Otyp_class (x0, x1, x2) ->
Ast_409.Outcometree.Otyp_class
(x0, (copy_out_ident x1), (List.map copy_out_type x2))
| Ast_410.Outcometree.Otyp_constr (x0, x1) ->
Ast_409.Outcometree.Otyp_constr
((copy_out_ident x0), (List.map copy_out_type x1))
| Ast_410.Outcometree.Otyp_manifest (x0, x1) ->
Ast_409.Outcometree.Otyp_manifest
((copy_out_type x0), (copy_out_type x1))
| Ast_410.Outcometree.Otyp_object (x0, x1) ->
Ast_409.Outcometree.Otyp_object
((List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1))) x0),
(Option.map (fun x -> x) x1))
| Ast_410.Outcometree.Otyp_record x0 ->
Ast_409.Outcometree.Otyp_record
(List.map
(fun x -> let (x0, x1, x2) = x in (x0, x1, (copy_out_type x2))) x0)
| Ast_410.Outcometree.Otyp_stuff x0 -> Ast_409.Outcometree.Otyp_stuff x0
| Ast_410.Outcometree.Otyp_sum x0 ->
Ast_409.Outcometree.Otyp_sum
(List.map
(fun x ->
let (x0, x1, x2) = x in
(x0, (List.map copy_out_type x1),
(Option.map copy_out_type x2))) x0)
| Ast_410.Outcometree.Otyp_tuple x0 ->
Ast_409.Outcometree.Otyp_tuple (List.map copy_out_type x0)
| Ast_410.Outcometree.Otyp_var (x0, x1) ->
Ast_409.Outcometree.Otyp_var (x0, x1)
| Ast_410.Outcometree.Otyp_variant (x0, x1, x2, x3) ->
Ast_409.Outcometree.Otyp_variant
(x0, (copy_out_variant x1), x2,
(Option.map (fun x -> List.map (fun x -> x) x) x3))
| Ast_410.Outcometree.Otyp_poly (x0, x1) ->
Ast_409.Outcometree.Otyp_poly
((List.map (fun x -> x) x0), (copy_out_type x1))
| Ast_410.Outcometree.Otyp_module (x0, x1, x2) ->
Ast_409.Outcometree.Otyp_module
((copy_out_ident x0), (List.map (fun x -> x) x1),
(List.map copy_out_type x2))
| Ast_410.Outcometree.Otyp_attribute (x0, x1) ->
Ast_409.Outcometree.Otyp_attribute
((copy_out_type x0), (copy_out_attribute x1))
and copy_out_attribute :
Ast_410.Outcometree.out_attribute -> Ast_409.Outcometree.out_attribute =
fun { Ast_410.Outcometree.oattr_name = oattr_name } ->
{ Ast_409.Outcometree.oattr_name = oattr_name }
and copy_out_variant :
Ast_410.Outcometree.out_variant -> Ast_409.Outcometree.out_variant =
function
| Ast_410.Outcometree.Ovar_fields x0 ->
Ast_409.Outcometree.Ovar_fields
(List.map
(fun x ->
let (x0, x1, x2) = x in (x0, x1, (List.map copy_out_type x2)))
x0)
| Ast_410.Outcometree.Ovar_typ x0 ->
Ast_409.Outcometree.Ovar_typ (copy_out_type x0)
and copy_out_value :
Ast_410.Outcometree.out_value -> Ast_409.Outcometree.out_value =
function
| Ast_410.Outcometree.Oval_array x0 ->
Ast_409.Outcometree.Oval_array (List.map copy_out_value x0)
| Ast_410.Outcometree.Oval_char x0 -> Ast_409.Outcometree.Oval_char x0
| Ast_410.Outcometree.Oval_constr (x0, x1) ->
Ast_409.Outcometree.Oval_constr
((copy_out_ident x0), (List.map copy_out_value x1))
| Ast_410.Outcometree.Oval_ellipsis -> Ast_409.Outcometree.Oval_ellipsis
| Ast_410.Outcometree.Oval_float x0 -> Ast_409.Outcometree.Oval_float x0
| Ast_410.Outcometree.Oval_int x0 -> Ast_409.Outcometree.Oval_int x0
| Ast_410.Outcometree.Oval_int32 x0 -> Ast_409.Outcometree.Oval_int32 x0
| Ast_410.Outcometree.Oval_int64 x0 -> Ast_409.Outcometree.Oval_int64 x0
| Ast_410.Outcometree.Oval_nativeint x0 ->
Ast_409.Outcometree.Oval_nativeint x0
| Ast_410.Outcometree.Oval_list x0 ->
Ast_409.Outcometree.Oval_list (List.map copy_out_value x0)
| Ast_410.Outcometree.Oval_printer x0 ->
Ast_409.Outcometree.Oval_printer x0
| Ast_410.Outcometree.Oval_record x0 ->
Ast_409.Outcometree.Oval_record
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_ident x0), (copy_out_value x1)))
x0)
| Ast_410.Outcometree.Oval_string (x0, x1, x2) ->
Ast_409.Outcometree.Oval_string (x0, x1, (copy_out_string x2))
| Ast_410.Outcometree.Oval_stuff x0 -> Ast_409.Outcometree.Oval_stuff x0
| Ast_410.Outcometree.Oval_tuple x0 ->
Ast_409.Outcometree.Oval_tuple (List.map copy_out_value x0)
| Ast_410.Outcometree.Oval_variant (x0, x1) ->
Ast_409.Outcometree.Oval_variant (x0, (Option.map copy_out_value x1))
and copy_out_string :
Ast_410.Outcometree.out_string -> Ast_409.Outcometree.out_string =
function
| Ast_410.Outcometree.Ostr_string -> Ast_409.Outcometree.Ostr_string
| Ast_410.Outcometree.Ostr_bytes -> Ast_409.Outcometree.Ostr_bytes
and copy_out_ident :
Ast_410.Outcometree.out_ident -> Ast_409.Outcometree.out_ident =
function
| Ast_410.Outcometree.Oide_apply (x0, x1) ->
Ast_409.Outcometree.Oide_apply
((copy_out_ident x0), (copy_out_ident x1))
| Ast_410.Outcometree.Oide_dot (x0, x1) ->
Ast_409.Outcometree.Oide_dot ((copy_out_ident x0), x1)
| Ast_410.Outcometree.Oide_ident x0 ->
Ast_409.Outcometree.Oide_ident (copy_out_name x0)
and copy_out_name :
Ast_410.Outcometree.out_name -> Ast_409.Outcometree.out_name =
fun { Ast_410.Outcometree.printed_name = printed_name } ->
{ Ast_409.Outcometree.printed_name = printed_name }
================================================
FILE: src/vendored-omp/src/migrate_parsetree_410_411.ml
================================================
(**************************************************************************)
(* *)
(* OCaml Migrate Parsetree *)
(* *)
(* Frédéric Bour *)
(* *)
(* Copyright 2017 Institut National de Recherche en Informatique et *)
(* en Automatique (INRIA). *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
include Migrate_parsetree_410_411_migrate
================================================
FILE: src/vendored-omp/src/migrate_parsetree_410_411_migrate.ml
================================================
open Stdlib0
module From = Ast_410
module To = Ast_411
let rec copy_out_type_extension :
Ast_410.Outcometree.out_type_extension ->
Ast_411.Outcometree.out_type_extension
=
fun
{ Ast_410.Outcometree.otyext_name = otyext_name;
Ast_410.Outcometree.otyext_params = otyext_params;
Ast_410.Outcometree.otyext_constructors = otyext_constructors;
Ast_410.Outcometree.otyext_private = otyext_private }
->
{
Ast_411.Outcometree.otyext_name = otyext_name;
Ast_411.Outcometree.otyext_params =
(List.map (fun x -> x) otyext_params);
Ast_411.Outcometree.otyext_constructors =
(List.map
(fun x ->
let (x0, x1, x2) = x in
(x0, (List.map copy_out_type x1),
(Option.map copy_out_type x2))) otyext_constructors);
Ast_411.Outcometree.otyext_private = (copy_private_flag otyext_private)
}
and copy_out_phrase :
Ast_410.Outcometree.out_phrase -> Ast_411.Outcometree.out_phrase =
function
| Ast_410.Outcometree.Ophr_eval (x0, x1) ->
Ast_411.Outcometree.Ophr_eval ((copy_out_value x0), (copy_out_type x1))
| Ast_410.Outcometree.Ophr_signature x0 ->
Ast_411.Outcometree.Ophr_signature
(List.map
(fun x ->
let (x0, x1) = x in
((copy_out_sig_item x0), (Option.map copy_out_value x1))) x0)
| Ast_410.Outcometree.Ophr_exception x0 ->
Ast_411.Outcometree.Ophr_exception
(let (x0, x1) = x0 in (x0, (copy_out_value x1)))
and copy_out_sig_item :
Ast_410.Outcometree.out_sig_item -> Ast_411.Outcometree.out_sig_item =
function
| Ast_410.Outcometree.Osig_class (x0, x1, x2, x3, x4) ->
Ast_411.Outcometree.Osig_class
(x0, x1,
(List.map
(fun x ->
let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) x2),
(copy_out_class_type x3), (copy_out_rec_status x4))
| Ast_410.Outcometree.Osig_class_type (x0, x1, x2, x3, x4) ->
Ast_411.Outcometree.Osig_class_type
(x0, x1,
(List.map
(fun x ->
let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) x2),
(copy_out_class_type x3), (copy_out_rec_status x4))
| Ast_410.Outcometree.Osig_typext (x0, x1) ->
Ast_411.Outcometree.Osig_typext
((copy_out_extension_constructor x0), (copy_out_ext_status x1))
| Ast_410.Outcometree.Osig_modtype (x0, x1) ->
Ast_411.Outcometree.Osig_modtype (x0, (copy_out_module_type x1))
| Ast_410.Outcometree.Osig_module (x0, x1, x2) ->
Ast_411.Outcometree.Osig_module
(x0, (copy_out_module_type x1), (copy_out_rec_status x2))
| Ast_410.Outcometree.Osig_type (x0, x1) ->
Ast_411.Outcometree.Osig_type
((copy_out_type_decl x0), (copy_out_rec_status x1))
| Ast_410.Outcometree.Osig_value x0 ->
Ast_411.Outcometree.Osig_value (copy_out_val_decl x0)
| Ast_410.Outcometree.Osig_ellipsis -> Ast_411.Outcometree.Osig_ellipsis
and copy_out_val_decl :
Ast_410.Outcometree.out_val_decl -> Ast_411.Outcometree.out_val_decl =
fun
{ Ast_410.Outcometree.oval_name = oval_name;
Ast_410.Outcometree.oval_type = oval_type;
Ast_410.Outcometree.oval_prims = oval_prims;
Ast_410.Outcometree.oval_attributes = oval_attributes }
->
{
Ast_411.Outcometree.oval_name = oval_name;
Ast_411.Outcometree.oval_type = (copy_out_type oval_type);
Ast_411.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims);
Ast_411.Outcometree.oval_attributes =
(List.map copy_out_attribute oval_attributes)
}
and copy_out_type_decl :
Ast_410.Outcometree.out_type_decl -> Ast_411.Outcometree.out_type_decl =
fun
{ Ast_410.Outcometree.otype_name = otype_name;
Ast_410.Outcometree.otype_params = otype_params;
Ast_410.Outcometree.otype_type = otype_type;
Ast_410.Outcometree.otype_private = otype_private;
Ast_410.Outcometree.otype_immediate = otype_immediate;
Ast_410.Outcometree.otype_unboxed = otype_unboxed;
Ast_410.Outcometree.otype_cstrs = otype_cstrs }
->
{
Ast_411.Outcometree.otype_name = otype_name;
Ast_411.Outcometree.otype_params =
(List.map
(fun x ->
let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1))))
otype_params);
Ast_411.Outcometree.otype_type = (copy_out_type otype_type);
Ast_411.Outcometree.otype_private = (copy_private_flag otype_private);
Ast_411.Outcometree.otype_immediate =
(copy_Type_immediacy_t otype_immediate);
Ast_411.Outcometree.otype_unboxed = otype_unboxed;
Ast_411.Outcometree.otype_cstrs =
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_type x0), (copy_out_type x1)))
otype_cstrs)
}
and copy_Type_immediacy_t :
Ast_410.Type_immediacy.t -> Ast_411.Type_immediacy.t =
function
| Ast_410.Type_immediacy.Unknown -> Ast_411.Type_immediacy.Unknown
| Ast_410.Type_immediacy.Always -> Ast_411.Type_immediacy.Always
| Ast_410.Type_immediacy.Always_on_64bits ->
Ast_411.Type_immediacy.Always_on_64bits
and copy_out_module_type :
Ast_410.Outcometree.out_module_type -> Ast_411.Outcometree.out_module_type
=
function
| Ast_410.Outcometree.Omty_abstract -> Ast_411.Outcometree.Omty_abstract
| Ast_410.Outcometree.Omty_functor (x0, x1) ->
Ast_411.Outcometree.Omty_functor
((Option.map
(fun x ->
let (x0, x1) = x in
((Option.map (fun x -> x) x0), (copy_out_module_type x1))) x0),
(copy_out_module_type x1))
| Ast_410.Outcometree.Omty_ident x0 ->
Ast_411.Outcometree.Omty_ident (copy_out_ident x0)
| Ast_410.Outcometree.Omty_signature x0 ->
Ast_411.Outcometree.Omty_signature (List.map copy_out_sig_item x0)
| Ast_410.Outcometree.Omty_alias x0 ->
Ast_411.Outcometree.Omty_alias (copy_out_ident x0)
and copy_out_ext_status :
Ast_410.Outcometree.out_ext_status -> Ast_411.Outcometree.out_ext_status =
function
| Ast_410.Outcometree.Oext_first -> Ast_411.Outcometree.Oext_first
| Ast_410.Outcometree.Oext_next -> Ast_411.Outcometree.Oext_next
| Ast_410.Outcometree.Oext_exception -> Ast_411.Outcometree.Oext_exception
and copy_out_extension_constructor :
Ast_410.Outcometree.out_extension_constructor ->
Ast_411.Outcometree.out_extension_constructor
=
fun
{ Ast_410.Outcometree.oext_name = oext_name;
Ast_410.Outcometree.oext_type_name = oext_type_name;
Ast_410.Outcometree.oext_type_params = oext_type_params;
Ast_410.Outcometree.oext_args = oext_args;
Ast_410.Outcometree.oext_ret_type = oext_ret_type;
Ast_410.Outcometree.oext_private = oext_private }
->
{
Ast_411.Outcometree.oext_name = oext_name;
Ast_411.Outcometree.oext_type_name = oext_type_name;
Ast_411.Outcometree.oext_type_params =
(List.map (fun x -> x) oext_type_params);
Ast_411.Outcometree.oext_args = (List.map copy_out_type oext_args);
Ast_411.Outcometree.oext_ret_type =
(Option.map copy_out_type oext_ret_type);
Ast_411.Outcometree.oext_private = (copy_private_flag oext_private)
}
and copy_private_flag :
Ast_410.Asttypes.private_flag -> Ast_411.Asttypes.private_flag =
function
| Ast_410.Asttypes.Private -> Ast_411.Asttypes.Private
| Ast_410.Asttypes.Public -> Ast_411.Asttypes.Public
and copy_out_rec_status :
Ast_410.Outcometree.out_rec_status -> Ast_411.Outcometree.out_rec_status =
function
| Ast_410.Outcometree.Orec_not -> Ast_411.Outcometree.Orec_not
| Ast_410.Outcometree.Orec_first -> Ast_411.Outcometree.Orec_first
| Ast_410.Outcometree.Orec_next -> Ast_411.Outcometree.Orec_next
and copy_out_class_type :
Ast_410.Outcometree.out_class_type -> Ast_411.Outcometree.out_class_type =
function
| Ast_410.Outcometree.Octy_constr (x0, x1) ->
Ast_411.Outcometree.Octy_constr
((copy_out_ident x0), (List.map copy_out_type x1))
| Ast_410.Outcometree.Octy_arrow (x0, x1, x2) ->
Ast_411.Outcometree.Octy_arrow
(x0, (copy_out_type x1), (copy_out_class_type x2))
| Ast_410.Outcometree.Octy_signature (x0, x1) ->
Ast_411.Outcometree.Octy_signature
((Option.map copy_out_type x0),
(List.map copy_out_class_sig_item x1))
and copy_out_class_sig_item :
Ast_410.Outcometree.out_class_sig_item ->
Ast_411.Outcometree.out_class_sig_item
=
function
| Ast_410.Outcometree.Ocsg_constraint (x0, x1) ->
Ast_411.Outcometree.Ocsg_constraint
((copy_out_type x0), (copy_out_type x1))
| Ast_410.Outcometree.Ocsg_method (x0, x1, x2, x3) ->
Ast_411.Outcometree.Ocsg_method (x0, x1, x2, (copy_out_type x3))
| Ast_410.Outcometree.Ocsg_value (x0, x1, x2, x3) ->
Ast_411.Outcometree.Ocsg_value (x0, x1, x2, (copy_out_type x3))
and copy_out_type :
Ast_410.Outcometree.out_type -> Ast_411.Outcometree.out_type =
function
| Ast_410.Outcometree.Otyp_abstract -> Ast_411.Outcometree.Otyp_abstract
| Ast_410.Outcometree.Otyp_open -> Ast_411.Outcometree.Otyp_open
| Ast_410.Outcometree.Otyp_alias (x0, x1) ->
Ast_411.Outcometree.Otyp_alias ((copy_out_type x0), x1)
| Ast_410.Outcometree.Otyp_arrow (x0, x1, x2) ->
Ast_411.Outcometree.Otyp_arrow
(x0, (copy_out_type x1), (copy_out_type x2))
| Ast_410.Outcometree.Otyp_class (x0, x1, x2) ->
Ast_411.Outcometree.Otyp_class
(x0, (copy_out_ident x1), (List.map copy_out_type x2))
| Ast_410.Outcometree.Otyp_constr (x0, x1) ->
Ast_411.Outcometree.Otyp_constr
((copy_out_ident x0), (List.map copy_out_type x1))
| Ast_410.Outcometree.Otyp_manifest (x0, x1) ->
Ast_411.Outcometree.Otyp_manifest
((copy_out_type x0), (copy_out_type x1))
| Ast_410.Outcometree.Otyp_object (x0, x1) ->
Ast_411.Outcometree.Otyp_object
((List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1))) x0),
(Option.map (fun x -> x) x1))
| Ast_410.Outcometree.Otyp_record x0 ->
Ast_411.Outcometree.Otyp_record
(List.map
(fun x -> let (x0, x1, x2) = x in (x0, x1, (copy_out_type x2))) x0)
| Ast_410.Outcometree.Otyp_stuff x0 -> Ast_411.Outcometree.Otyp_stuff x0
| Ast_410.Outcometree.Otyp_sum x0 ->
Ast_411.Outcometree.Otyp_sum
(List.map
(fun x ->
let (x0, x1, x2) = x in
(x0, (List.map copy_out_type x1),
(Option.map copy_out_type x2))) x0)
| Ast_410.Outcometree.Otyp_tuple x0 ->
Ast_411.Outcometree.Otyp_tuple (List.map copy_out_type x0)
| Ast_410.Outcometree.Otyp_var (x0, x1) ->
Ast_411.Outcometree.Otyp_var (x0, x1)
| Ast_410.Outcometree.Otyp_variant (x0, x1, x2, x3) ->
Ast_411.Outcometree.Otyp_variant
(x0, (copy_out_variant x1), x2,
(Option.map (fun x -> List.map (fun x -> x) x) x3))
| Ast_410.Outcometree.Otyp_poly (x0, x1) ->
Ast_411.Outcometree.Otyp_poly
((List.map (fun x -> x) x0), (copy_out_type x1))
| Ast_410.Outcometree.Otyp_module (x0, x1, x2) ->
Ast_411.Outcometree.Otyp_module
((copy_out_ident x0), (List.map (fun x -> x) x1),
(List.map copy_out_type x2))
| Ast_410.Outcometree.Otyp_attribute (x0, x1) ->
Ast_411.Outcometree.Otyp_attribute
((copy_out_type x0), (copy_out_attribute x1))
and copy_out_attribute :
Ast_410.Outcometree.out_attribute -> Ast_411.Outcometree.out_attribute =
fun { Ast_410.Outcometree.oattr_name = oattr_name } ->
{ Ast_411.Outcometree.oattr_name = oattr_name }
and copy_out_variant :
Ast_410.Outcometree.out_variant -> Ast_411.Outcometree.out_variant =
function
| Ast_410.Outcometree.Ovar_fields x0 ->
Ast_411.Outcometree.Ovar_fields
(List.map
(fun x ->
let (x0, x1, x2) = x in (x0, x1, (List.map copy_out_type x2)))
x0)
| Ast_410.Outcometree.Ovar_typ x0 ->
Ast_411.Outcometree.Ovar_typ (copy_out_type x0)
and copy_out_value :
Ast_410.Outcometree.out_value -> Ast_411.Outcometree.out_value =
function
| Ast_410.Outcometree.Oval_array x0 ->
Ast_411.Outcometree.Oval_array (List.map copy_out_value x0)
| Ast_410.Outcometree.Oval_char x0 -> Ast_411.Outcometree.Oval_char x0
| Ast_410.Outcometree.Oval_constr (x0, x1) ->
Ast_411.Outcometree.Oval_constr
((copy_out_ident x0), (List.map copy_out_value x1))
| Ast_410.Outcometree.Oval_ellipsis -> Ast_411.Outcometree.Oval_ellipsis
| Ast_410.Outcometree.Oval_float x0 -> Ast_411.Outcometree.Oval_float x0
| Ast_410.Outcometree.Oval_int x0 -> Ast_411.Outcometree.Oval_int x0
| Ast_410.Outcometree.Oval_int32 x0 -> Ast_411.Outcometree.Oval_int32 x0
| Ast_410.Outcometree.Oval_int64 x0 -> Ast_411.Outcometree.Oval_int64 x0
| Ast_410.Outcometree.Oval_nativeint x0 ->
Ast_411.Outcometree.Oval_nativeint x0
| Ast_410.Outcometree.Oval_list x0 ->
Ast_411.Outcometree.Oval_list (List.map copy_out_value x0)
| Ast_410.Outcometree.Oval_printer x0 ->
Ast_411.Outcometree.Oval_printer x0
| Ast_410.Outcometree.Oval_record x0 ->
Ast_411.Outcometree.Oval_record
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_ident x0), (copy_out_value x1)))
x0)
| Ast_410.Outcometree.Oval_string (x0, x1, x2) ->
Ast_411.Outcometree.Oval_string (x0, x1, (copy_out_string x2))
| Ast_410.Outcometree.Oval_stuff x0 -> Ast_411.Outcometree.Oval_stuff x0
| Ast_410.Outcometree.Oval_tuple x0 ->
Ast_411.Outcometree.Oval_tuple (List.map copy_out_value x0)
| Ast_410.Outcometree.Oval_variant (x0, x1) ->
Ast_411.Outcometree.Oval_variant (x0, (Option.map copy_out_value x1))
and copy_out_string :
Ast_410.Outcometree.out_string -> Ast_411.Outcometree.out_string =
function
| Ast_410.Outcometree.Ostr_string -> Ast_411.Outcometree.Ostr_string
| Ast_410.Outcometree.Ostr_bytes -> Ast_411.Outcometree.Ostr_bytes
and copy_out_ident :
Ast_410.Outcometree.out_ident -> Ast_411.Outcometree.out_ident =
function
| Ast_410.Outcometree.Oide_apply (x0, x1) ->
Ast_411.Outcometree.Oide_apply
((copy_out_ident x0), (copy_out_ident x1))
| Ast_410.Outcometree.Oide_dot (x0, x1) ->
Ast_411.Outcometree.Oide_dot ((copy_out_ident x0), x1)
| Ast_410.Outcometree.Oide_ident x0 ->
Ast_411.Outcometree.Oide_ident (copy_out_name x0)
and copy_out_name :
Ast_410.Outcometree.out_name -> Ast_411.Outcometree.out_name =
fun { Ast_410.Outcometree.printed_name = printed_name } ->
{ Ast_411.Outcometree.printed_name = printed_name }
================================================
FILE: src/vendored-omp/src/migrate_parsetree_411_410.ml
================================================
(**************************************************************************)
(* *)
(* OCaml Migrate Parsetree *)
(* *)
(* Frédéric Bour *)
(* *)
(* Copyright 2017 Institut National de Recherche en Informatique et *)
(* en Automatique (INRIA). *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
include Migrate_parsetree_411_410_migrate
================================================
FILE: src/vendored-omp/src/migrate_parsetree_411_410_migrate.ml
================================================
open Stdlib0
module From = Ast_411
module To = Ast_410
let rec copy_out_type_extension :
Ast_411.Outcometree.out_type_extension ->
Ast_410.Outcometree.out_type_extension
=
fun
{ Ast_411.Outcometree.otyext_name = otyext_name;
Ast_411.Outcometree.otyext_params = otyext_params;
Ast_411.Outcometree.otyext_constructors = otyext_constructors;
Ast_411.Outcometree.otyext_private = otyext_private }
->
{
Ast_410.Outcometree.otyext_name = otyext_name;
Ast_410.Outcometree.otyext_params =
(List.map (fun x -> x) otyext_params);
Ast_410.Outcometree.otyext_constructors =
(List.map
(fun x ->
let (x0, x1, x2) = x in
(x0, (List.map copy_out_type x1),
(Option.map copy_out_type x2))) otyext_constructors);
Ast_410.Outcometree.otyext_private = (copy_private_flag otyext_private)
}
and copy_out_phrase :
Ast_411.Outcometree.out_phrase -> Ast_410.Outcometree.out_phrase =
function
| Ast_411.Outcometree.Ophr_eval (x0, x1) ->
Ast_410.Outcometree.Ophr_eval ((copy_out_value x0), (copy_out_type x1))
| Ast_411.Outcometree.Ophr_signature x0 ->
Ast_410.Outcometree.Ophr_signature
(List.map
(fun x ->
let (x0, x1) = x in
((copy_out_sig_item x0), (Option.map copy_out_value x1))) x0)
| Ast_411.Outcometree.Ophr_exception x0 ->
Ast_410.Outcometree.Ophr_exception
(let (x0, x1) = x0 in (x0, (copy_out_value x1)))
and copy_out_sig_item :
Ast_411.Outcometree.out_sig_item -> Ast_410.Outcometree.out_sig_item =
function
| Ast_411.Outcometree.Osig_class (x0, x1, x2, x3, x4) ->
Ast_410.Outcometree.Osig_class
(x0, x1,
(List.map
(fun x ->
let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) x2),
(copy_out_class_type x3), (copy_out_rec_status x4))
| Ast_411.Outcometree.Osig_class_type (x0, x1, x2, x3, x4) ->
Ast_410.Outcometree.Osig_class_type
(x0, x1,
(List.map
(fun x ->
let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) x2),
(copy_out_class_type x3), (copy_out_rec_status x4))
| Ast_411.Outcometree.Osig_typext (x0, x1) ->
Ast_410.Outcometree.Osig_typext
((copy_out_extension_constructor x0), (copy_out_ext_status x1))
| Ast_411.Outcometree.Osig_modtype (x0, x1) ->
Ast_410.Outcometree.Osig_modtype (x0, (copy_out_module_type x1))
| Ast_411.Outcometree.Osig_module (x0, x1, x2) ->
Ast_410.Outcometree.Osig_module
(x0, (copy_out_module_type x1), (copy_out_rec_status x2))
| Ast_411.Outcometree.Osig_type (x0, x1) ->
Ast_410.Outcometree.Osig_type
((copy_out_type_decl x0), (copy_out_rec_status x1))
| Ast_411.Outcometree.Osig_value x0 ->
Ast_410.Outcometree.Osig_value (copy_out_val_decl x0)
| Ast_411.Outcometree.Osig_ellipsis -> Ast_410.Outcometree.Osig_ellipsis
and copy_out_val_decl :
Ast_411.Outcometree.out_val_decl -> Ast_410.Outcometree.out_val_decl =
fun
{ Ast_411.Outcometree.oval_name = oval_name;
Ast_411.Outcometree.oval_type = oval_type;
Ast_411.Outcometree.oval_prims = oval_prims;
Ast_411.Outcometree.oval_attributes = oval_attributes }
->
{
Ast_410.Outcometree.oval_name = oval_name;
Ast_410.Outcometree.oval_type = (copy_out_type oval_type);
Ast_410.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims);
Ast_410.Outcometree.oval_attributes =
(List.map copy_out_attribute oval_attributes)
}
and copy_out_type_decl :
Ast_411.Outcometree.out_type_decl -> Ast_410.Outcometree.out_type_decl =
fun
{ Ast_411.Outcometree.otype_name = otype_name;
Ast_411.Outcometree.otype_params = otype_params;
Ast_411.Outcometree.otype_type = otype_type;
Ast_411.Outcometree.otype_private = otype_private;
Ast_411.Outcometree.otype_immediate = otype_immediate;
Ast_411.Outcometree.otype_unboxed = otype_unboxed;
Ast_411.Outcometree.otype_cstrs = otype_cstrs }
->
{
Ast_410.Outcometree.otype_name = otype_name;
Ast_410.Outcometree.otype_params =
(List.map
(fun x ->
let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1))))
otype_params);
Ast_410.Outcometree.otype_type = (copy_out_type otype_type);
Ast_410.Outcometree.otype_private = (copy_private_flag otype_private);
Ast_410.Outcometree.otype_immediate =
(copy_Type_immediacy_t otype_immediate);
Ast_410.Outcometree.otype_unboxed = otype_unboxed;
Ast_410.Outcometree.otype_cstrs =
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_type x0), (copy_out_type x1)))
otype_cstrs)
}
and copy_Type_immediacy_t :
Ast_411.Type_immediacy.t -> Ast_410.Type_immediacy.t =
function
| Ast_411.Type_immediacy.Unknown -> Ast_410.Type_immediacy.Unknown
| Ast_411.Type_immediacy.Always -> Ast_410.Type_immediacy.Always
| Ast_411.Type_immediacy.Always_on_64bits ->
Ast_410.Type_immediacy.Always_on_64bits
and copy_out_module_type :
Ast_411.Outcometree.out_module_type -> Ast_410.Outcometree.out_module_type
=
function
| Ast_411.Outcometree.Omty_abstract -> Ast_410.Outcometree.Omty_abstract
| Ast_411.Outcometree.Omty_functor (x0, x1) ->
Ast_410.Outcometree.Omty_functor
((Option.map
(fun x ->
let (x0, x1) = x in
((Option.map (fun x -> x) x0), (copy_out_module_type x1))) x0),
(copy_out_module_type x1))
| Ast_411.Outcometree.Omty_ident x0 ->
Ast_410.Outcometree.Omty_ident (copy_out_ident x0)
| Ast_411.Outcometree.Omty_signature x0 ->
Ast_410.Outcometree.Omty_signature (List.map copy_out_sig_item x0)
| Ast_411.Outcometree.Omty_alias x0 ->
Ast_410.Outcometree.Omty_alias (copy_out_ident x0)
and copy_out_ext_status :
Ast_411.Outcometree.out_ext_status -> Ast_410.Outcometree.out_ext_status =
function
| Ast_411.Outcometree.Oext_first -> Ast_410.Outcometree.Oext_first
| Ast_411.Outcometree.Oext_next -> Ast_410.Outcometree.Oext_next
| Ast_411.Outcometree.Oext_exception -> Ast_410.Outcometree.Oext_exception
and copy_out_extension_constructor :
Ast_411.Outcometree.out_extension_constructor ->
Ast_410.Outcometree.out_extension_constructor
=
fun
{ Ast_411.Outcometree.oext_name = oext_name;
Ast_411.Outcometree.oext_type_name = oext_type_name;
Ast_411.Outcometree.oext_type_params = oext_type_params;
Ast_411.Outcometree.oext_args = oext_args;
Ast_411.Outcometree.oext_ret_type = oext_ret_type;
Ast_411.Outcometree.oext_private = oext_private }
->
{
Ast_410.Outcometree.oext_name = oext_name;
Ast_410.Outcometree.oext_type_name = oext_type_name;
Ast_410.Outcometree.oext_type_params =
(List.map (fun x -> x) oext_type_params);
Ast_410.Outcometree.oext_args = (List.map copy_out_type oext_args);
Ast_410.Outcometree.oext_ret_type =
(Option.map copy_out_type oext_ret_type);
Ast_410.Outcometree.oext_private = (copy_private_flag oext_private)
}
and copy_private_flag :
Ast_411.Asttypes.private_flag -> Ast_410.Asttypes.private_flag =
function
| Ast_411.Asttypes.Private -> Ast_410.Asttypes.Private
| Ast_411.Asttypes.Public -> Ast_410.Asttypes.Public
and copy_out_rec_status :
Ast_411.Outcometree.out_rec_status -> Ast_410.Outcometree.out_rec_status =
function
| Ast_411.Outcometree.Orec_not -> Ast_410.Outcometree.Orec_not
| Ast_411.Outcometree.Orec_first -> Ast_410.Outcometree.Orec_first
| Ast_411.Outcometree.Orec_next -> Ast_410.Outcometree.Orec_next
and copy_out_class_type :
Ast_411.Outcometree.out_class_type -> Ast_410.Outcometree.out_class_type =
function
| Ast_411.Outcometree.Octy_constr (x0, x1) ->
Ast_410.Outcometree.Octy_constr
((copy_out_ident x0), (List.map copy_out_type x1))
| Ast_411.Outcometree.Octy_arrow (x0, x1, x2) ->
Ast_410.Outcometree.Octy_arrow
(x0, (copy_out_type x1), (copy_out_class_type x2))
| Ast_411.Outcometree.Octy_signature (x0, x1) ->
Ast_410.Outcometree.Octy_signature
((Option.map copy_out_type x0),
(List.map copy_out_class_sig_item x1))
and copy_out_class_sig_item :
Ast_411.Outcometree.out_class_sig_item ->
Ast_410.Outcometree.out_class_sig_item
=
function
| Ast_411.Outcometree.Ocsg_constraint (x0, x1) ->
Ast_410.Outcometree.Ocsg_constraint
((copy_out_type x0), (copy_out_type x1))
| Ast_411.Outcometree.Ocsg_method (x0, x1, x2, x3) ->
Ast_410.Outcometree.Ocsg_method (x0, x1, x2, (copy_out_type x3))
| Ast_411.Outcometree.Ocsg_value (x0, x1, x2, x3) ->
Ast_410.Outcometree.Ocsg_value (x0, x1, x2, (copy_out_type x3))
and copy_out_type :
Ast_411.Outcometree.out_type -> Ast_410.Outcometree.out_type =
function
| Ast_411.Outcometree.Otyp_abstract -> Ast_410.Outcometree.Otyp_abstract
| Ast_411.Outcometree.Otyp_open -> Ast_410.Outcometree.Otyp_open
| Ast_411.Outcometree.Otyp_alias (x0, x1) ->
Ast_410.Outcometree.Otyp_alias ((copy_out_type x0), x1)
| Ast_411.Outcometree.Otyp_arrow (x0, x1, x2) ->
Ast_410.Outcometree.Otyp_arrow
(x0, (copy_out_type x1), (copy_out_type x2))
| Ast_411.Outcometree.Otyp_class (x0, x1, x2) ->
Ast_410.Outcometree.Otyp_class
(x0, (copy_out_ident x1), (List.map copy_out_type x2))
| Ast_411.Outcometree.Otyp_constr (x0, x1) ->
Ast_410.Outcometree.Otyp_constr
((copy_out_ident x0), (List.map copy_out_type x1))
| Ast_411.Outcometree.Otyp_manifest (x0, x1) ->
Ast_410.Outcometree.Otyp_manifest
((copy_out_type x0), (copy_out_type x1))
| Ast_411.Outcometree.Otyp_object (x0, x1) ->
Ast_410.Outcometree.Otyp_object
((List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1))) x0),
(Option.map (fun x -> x) x1))
| Ast_411.Outcometree.Otyp_record x0 ->
Ast_410.Outcometree.Otyp_record
(List.map
(fun x -> let (x0, x1, x2) = x in (x0, x1, (copy_out_type x2))) x0)
| Ast_411.Outcometree.Otyp_stuff x0 -> Ast_410.Outcometree.Otyp_stuff x0
| Ast_411.Outcometree.Otyp_sum x0 ->
Ast_410.Outcometree.Otyp_sum
(List.map
(fun x ->
let (x0, x1, x2) = x in
(x0, (List.map copy_out_type x1),
(Option.map copy_out_type x2))) x0)
| Ast_411.Outcometree.Otyp_tuple x0 ->
Ast_410.Outcometree.Otyp_tuple (List.map copy_out_type x0)
| Ast_411.Outcometree.Otyp_var (x0, x1) ->
Ast_410.Outcometree.Otyp_var (x0, x1)
| Ast_411.Outcometree.Otyp_variant (x0, x1, x2, x3) ->
Ast_410.Outcometree.Otyp_variant
(x0, (copy_out_variant x1), x2,
(Option.map (fun x -> List.map (fun x -> x) x) x3))
| Ast_411.Outcometree.Otyp_poly (x0, x1) ->
Ast_410.Outcometree.Otyp_poly
((List.map (fun x -> x) x0), (copy_out_type x1))
| Ast_411.Outcometree.Otyp_module (x0, x1, x2) ->
Ast_410.Outcometree.Otyp_module
((copy_out_ident x0), (List.map (fun x -> x) x1),
(List.map copy_out_type x2))
| Ast_411.Outcometree.Otyp_attribute (x0, x1) ->
Ast_410.Outcometree.Otyp_attribute
((copy_out_type x0), (copy_out_attribute x1))
and copy_out_attribute :
Ast_411.Outcometree.out_attribute -> Ast_410.Outcometree.out_attribute =
fun { Ast_411.Outcometree.oattr_name = oattr_name } ->
{ Ast_410.Outcometree.oattr_name = oattr_name }
and copy_out_variant :
Ast_411.Outcometree.out_variant -> Ast_410.Outcometree.out_variant =
function
| Ast_411.Outcometree.Ovar_fields x0 ->
Ast_410.Outcometree.Ovar_fields
(List.map
(fun x ->
let (x0, x1, x2) = x in (x0, x1, (List.map copy_out_type x2)))
x0)
| Ast_411.Outcometree.Ovar_typ x0 ->
Ast_410.Outcometree.Ovar_typ (copy_out_type x0)
and copy_out_value :
Ast_411.Outcometree.out_value -> Ast_410.Outcometree.out_value =
function
| Ast_411.Outcometree.Oval_array x0 ->
Ast_410.Outcometree.Oval_array (List.map copy_out_value x0)
| Ast_411.Outcometree.Oval_char x0 -> Ast_410.Outcometree.Oval_char x0
| Ast_411.Outcometree.Oval_constr (x0, x1) ->
Ast_410.Outcometree.Oval_constr
((copy_out_ident x0), (List.map copy_out_value x1))
| Ast_411.Outcometree.Oval_ellipsis -> Ast_410.Outcometree.Oval_ellipsis
| Ast_411.Outcometree.Oval_float x0 -> Ast_410.Outcometree.Oval_float x0
| Ast_411.Outcometree.Oval_int x0 -> Ast_410.Outcometree.Oval_int x0
| Ast_411.Outcometree.Oval_int32 x0 -> Ast_410.Outcometree.Oval_int32 x0
| Ast_411.Outcometree.Oval_int64 x0 -> Ast_410.Outcometree.Oval_int64 x0
| Ast_411.Outcometree.Oval_nativeint x0 ->
Ast_410.Outcometree.Oval_nativeint x0
| Ast_411.Outcometree.Oval_list x0 ->
Ast_410.Outcometree.Oval_list (List.map copy_out_value x0)
| Ast_411.Outcometree.Oval_printer x0 ->
Ast_410.Outcometree.Oval_printer x0
| Ast_411.Outcometree.Oval_record x0 ->
Ast_410.Outcometree.Oval_record
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_ident x0), (copy_out_value x1)))
x0)
| Ast_411.Outcometree.Oval_string (x0, x1, x2) ->
Ast_410.Outcometree.Oval_string (x0, x1, (copy_out_string x2))
| Ast_411.Outcometree.Oval_stuff x0 -> Ast_410.Outcometree.Oval_stuff x0
| Ast_411.Outcometree.Oval_tuple x0 ->
Ast_410.Outcometree.Oval_tuple (List.map copy_out_value x0)
| Ast_411.Outcometree.Oval_variant (x0, x1) ->
Ast_410.Outcometree.Oval_variant (x0, (Option.map copy_out_value x1))
and copy_out_string :
Ast_411.Outcometree.out_string -> Ast_410.Outcometree.out_string =
function
| Ast_411.Outcometree.Ostr_string -> Ast_410.Outcometree.Ostr_string
| Ast_411.Outcometree.Ostr_bytes -> Ast_410.Outcometree.Ostr_bytes
and copy_out_ident :
Ast_411.Outcometree.out_ident -> Ast_410.Outcometree.out_ident =
function
| Ast_411.Outcometree.Oide_apply (x0, x1) ->
Ast_410.Outcometree.Oide_apply
((copy_out_ident x0), (copy_out_ident x1))
| Ast_411.Outcometree.Oide_dot (x0, x1) ->
Ast_410.Outcometree.Oide_dot ((copy_out_ident x0), x1)
| Ast_411.Outcometree.Oide_ident x0 ->
Ast_410.Outcometree.Oide_ident (copy_out_name x0)
and copy_out_name :
Ast_411.Outcometree.out_name -> Ast_410.Outcometree.out_name =
fun { Ast_411.Outcometree.printed_name = printed_name } ->
{ Ast_410.Outcometree.printed_name = printed_name }
================================================
FILE: src/vendored-omp/src/migrate_parsetree_411_412.ml
================================================
(**************************************************************************)
(* *)
(* OCaml Migrate Parsetree *)
(* *)
(* Frédéric Bour *)
(* *)
(* Copyright 2017 Institut National de Recherche en Informatique et *)
(* en Automatique (INRIA). *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
include Migrate_parsetree_411_412_migrate
================================================
FILE: src/vendored-omp/src/migrate_parsetree_411_412_migrate.ml
================================================
open Stdlib0
module From = Ast_411
module To = Ast_412
let rec copy_out_type_extension :
Ast_411.Outcometree.out_type_extension ->
Ast_412.Outcometree.out_type_extension
=
fun
{ Ast_411.Outcometree.otyext_name = otyext_name;
Ast_411.Outcometree.otyext_params = otyext_params;
Ast_411.Outcometree.otyext_constructors = otyext_constructors;
Ast_411.Outcometree.otyext_private = otyext_private }
->
{
Ast_412.Outcometree.otyext_name = otyext_name;
Ast_412.Outcometree.otyext_params =
(List.map (fun x -> x) otyext_params);
Ast_412.Outcometree.otyext_constructors =
(List.map
(fun x ->
let (x0, x1, x2) = x in
(x0, (List.map copy_out_type x1),
(Option.map copy_out_type x2))) otyext_constructors);
Ast_412.Outcometree.otyext_private = (copy_private_flag otyext_private)
}
and copy_out_phrase :
Ast_411.Outcometree.out_phrase -> Ast_412.Outcometree.out_phrase =
function
| Ast_411.Outcometree.Ophr_eval (x0, x1) ->
Ast_412.Outcometree.Ophr_eval ((copy_out_value x0), (copy_out_type x1))
| Ast_411.Outcometree.Ophr_signature x0 ->
Ast_412.Outcometree.Ophr_signature
(List.map
(fun x ->
let (x0, x1) = x in
((copy_out_sig_item x0), (Option.map copy_out_value x1))) x0)
| Ast_411.Outcometree.Ophr_exception x0 ->
Ast_412.Outcometree.Ophr_exception
(let (x0, x1) = x0 in (x0, (copy_out_value x1)))
and copy_out_type_param : string * (bool * bool) -> Ast_412.Outcometree.out_type_param =
function (str, v) ->
let v =
match v with
| (true, false) -> Ast_412.Asttypes.Covariant
| (false, true) -> Ast_412.Asttypes.Contravariant
| (false, false) | (true, true) -> Ast_412.Asttypes.NoVariance
in
str, (v, Ast_412.Asttypes.NoInjectivity)
and copy_out_sig_item :
Ast_411.Outcometree.out_sig_item -> Ast_412.Outcometree.out_sig_item =
function
| Ast_411.Outcometree.Osig_class (x0, x1, x2, x3, x4) ->
Ast_412.Outcometree.Osig_class
(x0, x1,
(List.map copy_out_type_param x2),
(copy_out_class_type x3), (copy_out_rec_status x4))
| Ast_411.Outcometree.Osig_class_type (x0, x1, x2, x3, x4) ->
Ast_412.Outcometree.Osig_class_type
(x0, x1,
(List.map copy_out_type_param x2),
(copy_out_class_type x3), (copy_out_rec_status x4))
| Ast_411.Outcometree.Osig_typext (x0, x1) ->
Ast_412.Outcometree.Osig_typext
((copy_out_extension_constructor x0), (copy_out_ext_status x1))
| Ast_411.Outcometree.Osig_modtype (x0, x1) ->
Ast_412.Outcometree.Osig_modtype (x0, (copy_out_module_type x1))
| Ast_411.Outcometree.Osig_module (x0, x1, x2) ->
Ast_412.Outcometree.Osig_module
(x0, (copy_out_module_type x1), (copy_out_rec_status x2))
| Ast_411.Outcometree.Osig_type (x0, x1) ->
Ast_412.Outcometree.Osig_type
((copy_out_type_decl x0), (copy_out_rec_status x1))
| Ast_411.Outcometree.Osig_value x0 ->
Ast_412.Outcometree.Osig_value (copy_out_val_decl x0)
| Ast_411.Outcometree.Osig_ellipsis -> Ast_412.Outcometree.Osig_ellipsis
and copy_out_val_decl :
Ast_411.Outcometree.out_val_decl -> Ast_412.Outcometree.out_val_decl =
fun
{ Ast_411.Outcometree.oval_name = oval_name;
Ast_411.Outcometree.oval_type = oval_type;
Ast_411.Outcometree.oval_prims = oval_prims;
Ast_411.Outcometree.oval_attributes = oval_attributes }
->
{
Ast_412.Outcometree.oval_name = oval_name;
Ast_412.Outcometree.oval_type = (copy_out_type oval_type);
Ast_412.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims);
Ast_412.Outcometree.oval_attributes =
(List.map copy_out_attribute oval_attributes)
}
and copy_out_type_decl :
Ast_411.Outcometree.out_type_decl -> Ast_412.Outcometree.out_type_decl =
fun
{ Ast_411.Outcometree.otype_name = otype_name;
Ast_411.Outcometree.otype_params = otype_params;
Ast_411.Outcometree.otype_type = otype_type;
Ast_411.Outcometree.otype_private = otype_private;
Ast_411.Outcometree.otype_immediate = otype_immediate;
Ast_411.Outcometree.otype_unboxed = otype_unboxed;
Ast_411.Outcometree.otype_cstrs = otype_cstrs }
->
{
Ast_412.Outcometree.otype_name = otype_name;
Ast_412.Outcometree.otype_params =
(List.map copy_out_type_param otype_params);
Ast_412.Outcometree.otype_type = (copy_out_type otype_type);
Ast_412.Outcometree.otype_private = (copy_private_flag otype_private);
Ast_412.Outcometree.otype_immediate =
(copy_Type_immediacy_t otype_immediate);
Ast_412.Outcometree.otype_unboxed = otype_unboxed;
Ast_412.Outcometree.otype_cstrs =
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_type x0), (copy_out_type x1)))
otype_cstrs)
}
and copy_Type_immediacy_t :
Ast_411.Type_immediacy.t -> Ast_412.Type_immediacy.t =
function
| Ast_411.Type_immediacy.Unknown -> Ast_412.Type_immediacy.Unknown
| Ast_411.Type_immediacy.Always -> Ast_412.Type_immediacy.Always
| Ast_411.Type_immediacy.Always_on_64bits ->
Ast_412.Type_immediacy.Always_on_64bits
and copy_out_module_type :
Ast_411.Outcometree.out_module_type -> Ast_412.Outcometree.out_module_type
=
function
| Ast_411.Outcometree.Omty_abstract -> Ast_412.Outcometree.Omty_abstract
| Ast_411.Outcometree.Omty_functor (x0, x1) ->
Ast_412.Outcometree.Omty_functor
((Option.map
(fun x ->
let (x0, x1) = x in
((Option.map (fun x -> x) x0), (copy_out_module_type x1))) x0),
(copy_out_module_type x1))
| Ast_411.Outcometree.Omty_ident x0 ->
Ast_412.Outcometree.Omty_ident (copy_out_ident x0)
| Ast_411.Outcometree.Omty_signature x0 ->
Ast_412.Outcometree.Omty_signature (List.map copy_out_sig_item x0)
| Ast_411.Outcometree.Omty_alias x0 ->
Ast_412.Outcometree.Omty_alias (copy_out_ident x0)
and copy_out_ext_status :
Ast_411.Outcometree.out_ext_status -> Ast_412.Outcometree.out_ext_status =
function
| Ast_411.Outcometree.Oext_first -> Ast_412.Outcometree.Oext_first
| Ast_411.Outcometree.Oext_next -> Ast_412.Outcometree.Oext_next
| Ast_411.Outcometree.Oext_exception -> Ast_412.Outcometree.Oext_exception
and copy_out_extension_constructor :
Ast_411.Outcometree.out_extension_constructor ->
Ast_412.Outcometree.out_extension_constructor
=
fun
{ Ast_411.Outcometree.oext_name = oext_name;
Ast_411.Outcometree.oext_type_name = oext_type_name;
Ast_411.Outcometree.oext_type_params = oext_type_params;
Ast_411.Outcometree.oext_args = oext_args;
Ast_411.Outcometree.oext_ret_type = oext_ret_type;
Ast_411.Outcometree.oext_private = oext_private }
->
{
Ast_412.Outcometree.oext_name = oext_name;
Ast_412.Outcometree.oext_type_name = oext_type_name;
Ast_412.Outcometree.oext_type_params =
(List.map (fun x -> x) oext_type_params);
Ast_412.Outcometree.oext_args = (List.map copy_out_type oext_args);
Ast_412.Outcometree.oext_ret_type =
(Option.map copy_out_type oext_ret_type);
Ast_412.Outcometree.oext_private = (copy_private_flag oext_private)
}
and copy_private_flag :
Ast_411.Asttypes.private_flag -> Ast_412.Asttypes.private_flag =
function
| Ast_411.Asttypes.Private -> Ast_412.Asttypes.Private
| Ast_411.Asttypes.Public -> Ast_412.Asttypes.Public
and copy_out_rec_status :
Ast_411.Outcometree.out_rec_status -> Ast_412.Outcometree.out_rec_status =
function
| Ast_411.Outcometree.Orec_not -> Ast_412.Outcometree.Orec_not
| Ast_411.Outcometree.Orec_first -> Ast_412.Outcometree.Orec_first
| Ast_411.Outcometree.Orec_next -> Ast_412.Outcometree.Orec_next
and copy_out_class_type :
Ast_411.Outcometree.out_class_type -> Ast_412.Outcometree.out_class_type =
function
| Ast_411.Outcometree.Octy_constr (x0, x1) ->
Ast_412.Outcometree.Octy_constr
((copy_out_ident x0), (List.map copy_out_type x1))
| Ast_411.Outcometree.Octy_arrow (x0, x1, x2) ->
Ast_412.Outcometree.Octy_arrow
(x0, (copy_out_type x1), (copy_out_class_type x2))
| Ast_411.Outcometree.Octy_signature (x0, x1) ->
Ast_412.Outcometree.Octy_signature
((Option.map copy_out_type x0),
(List.map copy_out_class_sig_item x1))
and copy_out_class_sig_item :
Ast_411.Outcometree.out_class_sig_item ->
Ast_412.Outcometree.out_class_sig_item
=
function
| Ast_411.Outcometree.Ocsg_constraint (x0, x1) ->
Ast_412.Outcometree.Ocsg_constraint
((copy_out_type x0), (copy_out_type x1))
| Ast_411.Outcometree.Ocsg_method (x0, x1, x2, x3) ->
Ast_412.Outcometree.Ocsg_method (x0, x1, x2, (copy_out_type x3))
| Ast_411.Outcometree.Ocsg_value (x0, x1, x2, x3) ->
Ast_412.Outcometree.Ocsg_value (x0, x1, x2, (copy_out_type x3))
and copy_out_type :
Ast_411.Outcometree.out_type -> Ast_412.Outcometree.out_type =
function
| Ast_411.Outcometree.Otyp_abstract -> Ast_412.Outcometree.Otyp_abstract
| Ast_411.Outcometree.Otyp_open -> Ast_412.Outcometree.Otyp_open
| Ast_411.Outcometree.Otyp_alias (x0, x1) ->
Ast_412.Outcometree.Otyp_alias ((copy_out_type x0), x1)
| Ast_411.Outcometree.Otyp_arrow (x0, x1, x2) ->
Ast_412.Outcometree.Otyp_arrow
(x0, (copy_out_type x1), (copy_out_type x2))
| Ast_411.Outcometree.Otyp_class (x0, x1, x2) ->
Ast_412.Outcometree.Otyp_class
(x0, (copy_out_ident x1), (List.map copy_out_type x2))
| Ast_411.Outcometree.Otyp_constr (x0, x1) ->
Ast_412.Outcometree.Otyp_constr
((copy_out_ident x0), (List.map copy_out_type x1))
| Ast_411.Outcometree.Otyp_manifest (x0, x1) ->
Ast_412.Outcometree.Otyp_manifest
((copy_out_type x0), (copy_out_type x1))
| Ast_411.Outcometree.Otyp_object (x0, x1) ->
Ast_412.Outcometree.Otyp_object
((List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1))) x0),
(Option.map (fun x -> x) x1))
| Ast_411.Outcometree.Otyp_record x0 ->
Ast_412.Outcometree.Otyp_record
(List.map
(fun x -> let (x0, x1, x2) = x in (x0, x1, (copy_out_type x2))) x0)
| Ast_411.Outcometree.Otyp_stuff x0 -> Ast_412.Outcometree.Otyp_stuff x0
| Ast_411.Outcometree.Otyp_sum x0 ->
Ast_412.Outcometree.Otyp_sum
(List.map
(fun x ->
let (x0, x1, x2) = x in
(x0, (List.map copy_out_type x1),
(Option.map copy_out_type x2))) x0)
| Ast_411.Outcometree.Otyp_tuple x0 ->
Ast_412.Outcometree.Otyp_tuple (List.map copy_out_type x0)
| Ast_411.Outcometree.Otyp_var (x0, x1) ->
Ast_412.Outcometree.Otyp_var (x0, x1)
| Ast_411.Outcometree.Otyp_variant (x0, x1, x2, x3) ->
Ast_412.Outcometree.Otyp_variant
(x0, (copy_out_variant x1), x2,
(Option.map (fun x -> List.map (fun x -> x) x) x3))
| Ast_411.Outcometree.Otyp_poly (x0, x1) ->
Ast_412.Outcometree.Otyp_poly
((List.map (fun x -> x) x0), (copy_out_type x1))
| Ast_411.Outcometree.Otyp_module (x0, x1, x2) ->
Ast_412.Outcometree.Otyp_module
((copy_out_ident x0), (List.map (fun x -> x) x1),
(List.map copy_out_type x2))
| Ast_411.Outcometree.Otyp_attribute (x0, x1) ->
Ast_412.Outcometree.Otyp_attribute
((copy_out_type x0), (copy_out_attribute x1))
and copy_out_attribute :
Ast_411.Outcometree.out_attribute -> Ast_412.Outcometree.out_attribute =
fun { Ast_411.Outcometree.oattr_name = oattr_name } ->
{ Ast_412.Outcometree.oattr_name = oattr_name }
and copy_out_variant :
Ast_411.Outcometree.out_variant -> Ast_412.Outcometree.out_variant =
function
| Ast_411.Outcometree.Ovar_fields x0 ->
Ast_412.Outcometree.Ovar_fields
(List.map
(fun x ->
let (x0, x1, x2) = x in (x0, x1, (List.map copy_out_type x2)))
x0)
| Ast_411.Outcometree.Ovar_typ x0 ->
Ast_412.Outcometree.Ovar_typ (copy_out_type x0)
and copy_out_value :
Ast_411.Outcometree.out_value -> Ast_412.Outcometree.out_value =
function
| Ast_411.Outcometree.Oval_array x0 ->
Ast_412.Outcometree.Oval_array (List.map copy_out_value x0)
| Ast_411.Outcometree.Oval_char x0 -> Ast_412.Outcometree.Oval_char x0
| Ast_411.Outcometree.Oval_constr (x0, x1) ->
Ast_412.Outcometree.Oval_constr
((copy_out_ident x0), (List.map copy_out_value x1))
| Ast_411.Outcometree.Oval_ellipsis -> Ast_412.Outcometree.Oval_ellipsis
| Ast_411.Outcometree.Oval_float x0 -> Ast_412.Outcometree.Oval_float x0
| Ast_411.Outcometree.Oval_int x0 -> Ast_412.Outcometree.Oval_int x0
| Ast_411.Outcometree.Oval_int32 x0 -> Ast_412.Outcometree.Oval_int32 x0
| Ast_411.Outcometree.Oval_int64 x0 -> Ast_412.Outcometree.Oval_int64 x0
| Ast_411.Outcometree.Oval_nativeint x0 ->
Ast_412.Outcometree.Oval_nativeint x0
| Ast_411.Outcometree.Oval_list x0 ->
Ast_412.Outcometree.Oval_list (List.map copy_out_value x0)
| Ast_411.Outcometree.Oval_printer x0 ->
Ast_412.Outcometree.Oval_printer x0
| Ast_411.Outcometree.Oval_record x0 ->
Ast_412.Outcometree.Oval_record
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_ident x0), (copy_out_value x1)))
x0)
| Ast_411.Outcometree.Oval_string (x0, x1, x2) ->
Ast_412.Outcometree.Oval_string (x0, x1, (copy_out_string x2))
| Ast_411.Outcometree.Oval_stuff x0 -> Ast_412.Outcometree.Oval_stuff x0
| Ast_411.Outcometree.Oval_tuple x0 ->
Ast_412.Outcometree.Oval_tuple (List.map copy_out_value x0)
| Ast_411.Outcometree.Oval_variant (x0, x1) ->
Ast_412.Outcometree.Oval_variant (x0, (Option.map copy_out_value x1))
and copy_out_string :
Ast_411.Outcometree.out_string -> Ast_412.Outcometree.out_string =
function
| Ast_411.Outcometree.Ostr_string -> Ast_412.Outcometree.Ostr_string
| Ast_411.Outcometree.Ostr_bytes -> Ast_412.Outcometree.Ostr_bytes
and copy_out_ident :
Ast_411.Outcometree.out_ident -> Ast_412.Outcometree.out_ident =
function
| Ast_411.Outcometree.Oide_apply (x0, x1) ->
Ast_412.Outcometree.Oide_apply
((copy_out_ident x0), (copy_out_ident x1))
| Ast_411.Outcometree.Oide_dot (x0, x1) ->
Ast_412.Outcometree.Oide_dot ((copy_out_ident x0), x1)
| Ast_411.Outcometree.Oide_ident x0 ->
Ast_412.Outcometree.Oide_ident (copy_out_name x0)
and copy_out_name :
Ast_411.Outcometree.out_name -> Ast_412.Outcometree.out_name =
fun { Ast_411.Outcometree.printed_name = printed_name } ->
{ Ast_412.Outcometree.printed_name = printed_name }
================================================
FILE: src/vendored-omp/src/migrate_parsetree_412_411.ml
================================================
(**************************************************************************)
(* *)
(* OCaml Migrate Parsetree *)
(* *)
(* Frédéric Bour *)
(* *)
(* Copyright 2017 Institut National de Recherche en Informatique et *)
(* en Automatique (INRIA). *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
include Migrate_parsetree_412_411_migrate
================================================
FILE: src/vendored-omp/src/migrate_parsetree_412_411_migrate.ml
================================================
open Stdlib0
module From = Ast_412
module To = Ast_411
let rec copy_out_type_extension :
Ast_412.Outcometree.out_type_extension ->
Ast_411.Outcometree.out_type_extension
=
fun
{ Ast_412.Outcometree.otyext_name = otyext_name;
Ast_412.Outcometree.otyext_params = otyext_params;
Ast_412.Outcometree.otyext_constructors = otyext_constructors;
Ast_412.Outcometree.otyext_private = otyext_private }
->
{
Ast_411.Outcometree.otyext_name = otyext_name;
Ast_411.Outcometree.otyext_params =
(List.map (fun x -> x) otyext_params);
Ast_411.Outcometree.otyext_constructors =
(List.map
(fun x ->
let (x0, x1, x2) = x in
(x0, (List.map copy_out_type x1),
(Option.map copy_out_type x2))) otyext_constructors);
Ast_411.Outcometree.otyext_private = (copy_private_flag otyext_private)
}
and copy_out_phrase :
Ast_412.Outcometree.out_phrase -> Ast_411.Outcometree.out_phrase =
function
| Ast_412.Outcometree.Ophr_eval (x0, x1) ->
Ast_411.Outcometree.Ophr_eval ((copy_out_value x0), (copy_out_type x1))
| Ast_412.Outcometree.Ophr_signature x0 ->
Ast_411.Outcometree.Ophr_signature
(List.map
(fun x ->
let (x0, x1) = x in
((copy_out_sig_item x0), (Option.map copy_out_value x1))) x0)
| Ast_412.Outcometree.Ophr_exception x0 ->
Ast_411.Outcometree.Ophr_exception
(let (x0, x1) = x0 in (x0, (copy_out_value x1)))
and copy_out_sig_item :
Ast_412.Outcometree.out_sig_item -> Ast_411.Outcometree.out_sig_item =
function
| Ast_412.Outcometree.Osig_class (x0, x1, x2, x3, x4) ->
Ast_411.Outcometree.Osig_class
(x0, x1, (List.map copy_out_type_param x2), (copy_out_class_type x3),
(copy_out_rec_status x4))
| Ast_412.Outcometree.Osig_class_type (x0, x1, x2, x3, x4) ->
Ast_411.Outcometree.Osig_class_type
(x0, x1, (List.map copy_out_type_param x2), (copy_out_class_type x3),
(copy_out_rec_status x4))
| Ast_412.Outcometree.Osig_typext (x0, x1) ->
Ast_411.Outcometree.Osig_typext
((copy_out_extension_constructor x0), (copy_out_ext_status x1))
| Ast_412.Outcometree.Osig_modtype (x0, x1) ->
Ast_411.Outcometree.Osig_modtype (x0, (copy_out_module_type x1))
| Ast_412.Outcometree.Osig_module (x0, x1, x2) ->
Ast_411.Outcometree.Osig_module
(x0, (copy_out_module_type x1), (copy_out_rec_status x2))
| Ast_412.Outcometree.Osig_type (x0, x1) ->
Ast_411.Outcometree.Osig_type
((copy_out_type_decl x0), (copy_out_rec_status x1))
| Ast_412.Outcometree.Osig_value x0 ->
Ast_411.Outcometree.Osig_value (copy_out_val_decl x0)
| Ast_412.Outcometree.Osig_ellipsis -> Ast_411.Outcometree.Osig_ellipsis
and copy_out_val_decl :
Ast_412.Outcometree.out_val_decl -> Ast_411.Outcometree.out_val_decl =
fun
{ Ast_412.Outcometree.oval_name = oval_name;
Ast_412.Outcometree.oval_type = oval_type;
Ast_412.Outcometree.oval_prims = oval_prims;
Ast_412.Outcometree.oval_attributes = oval_attributes }
->
{
Ast_411.Outcometree.oval_name = oval_name;
Ast_411.Outcometree.oval_type = (copy_out_type oval_type);
Ast_411.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims);
Ast_411.Outcometree.oval_attributes =
(List.map copy_out_attribute oval_attributes)
}
and copy_out_type_decl :
Ast_412.Outcometree.out_type_decl -> Ast_411.Outcometree.out_type_decl =
fun
{ Ast_412.Outcometree.otype_name = otype_name;
Ast_412.Outcometree.otype_params = otype_params;
Ast_412.Outcometree.otype_type = otype_type;
Ast_412.Outcometree.otype_private = otype_private;
Ast_412.Outcometree.otype_immediate = otype_immediate;
Ast_412.Outcometree.otype_unboxed = otype_unboxed;
Ast_412.Outcometree.otype_cstrs = otype_cstrs }
->
{
Ast_411.Outcometree.otype_name = otype_name;
Ast_411.Outcometree.otype_params =
(List.map copy_out_type_param otype_params);
Ast_411.Outcometree.otype_type = (copy_out_type otype_type);
Ast_411.Outcometree.otype_private = (copy_private_flag otype_private);
Ast_411.Outcometree.otype_immediate =
(copy_Type_immediacy_t otype_immediate);
Ast_411.Outcometree.otype_unboxed = otype_unboxed;
Ast_411.Outcometree.otype_cstrs =
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_type x0), (copy_out_type x1)))
otype_cstrs)
}
and copy_Type_immediacy_t :
Ast_412.Type_immediacy.t -> Ast_411.Type_immediacy.t =
function
| Ast_412.Type_immediacy.Unknown -> Ast_411.Type_immediacy.Unknown
| Ast_412.Type_immediacy.Always -> Ast_411.Type_immediacy.Always
| Ast_412.Type_immediacy.Always_on_64bits ->
Ast_411.Type_immediacy.Always_on_64bits
and copy_out_module_type :
Ast_412.Outcometree.out_module_type -> Ast_411.Outcometree.out_module_type
=
function
| Ast_412.Outcometree.Omty_abstract -> Ast_411.Outcometree.Omty_abstract
| Ast_412.Outcometree.Omty_functor (x0, x1) ->
Ast_411.Outcometree.Omty_functor
((Option.map
(fun x ->
let (x0, x1) = x in
((Option.map (fun x -> x) x0), (copy_out_module_type x1))) x0),
(copy_out_module_type x1))
| Ast_412.Outcometree.Omty_ident x0 ->
Ast_411.Outcometree.Omty_ident (copy_out_ident x0)
| Ast_412.Outcometree.Omty_signature x0 ->
Ast_411.Outcometree.Omty_signature (List.map copy_out_sig_item x0)
| Ast_412.Outcometree.Omty_alias x0 ->
Ast_411.Outcometree.Omty_alias (copy_out_ident x0)
and copy_out_ext_status :
Ast_412.Outcometree.out_ext_status -> Ast_411.Outcometree.out_ext_status =
function
| Ast_412.Outcometree.Oext_first -> Ast_411.Outcometree.Oext_first
| Ast_412.Outcometree.Oext_next -> Ast_411.Outcometree.Oext_next
| Ast_412.Outcometree.Oext_exception -> Ast_411.Outcometree.Oext_exception
and copy_out_extension_constructor :
Ast_412.Outcometree.out_extension_constructor ->
Ast_411.Outcometree.out_extension_constructor
=
fun
{ Ast_412.Outcometree.oext_name = oext_name;
Ast_412.Outcometree.oext_type_name = oext_type_name;
Ast_412.Outcometree.oext_type_params = oext_type_params;
Ast_412.Outcometree.oext_args = oext_args;
Ast_412.Outcometree.oext_ret_type = oext_ret_type;
Ast_412.Outcometree.oext_private = oext_private }
->
{
Ast_411.Outcometree.oext_name = oext_name;
Ast_411.Outcometree.oext_type_name = oext_type_name;
Ast_411.Outcometree.oext_type_params =
(List.map (fun x -> x) oext_type_params);
Ast_411.Outcometree.oext_args = (List.map copy_out_type oext_args);
Ast_411.Outcometree.oext_ret_type =
(Option.map copy_out_type oext_ret_type);
Ast_411.Outcometree.oext_private = (copy_private_flag oext_private)
}
and copy_private_flag :
Ast_412.Asttypes.private_flag -> Ast_411.Asttypes.private_flag =
function
| Ast_412.Asttypes.Private -> Ast_411.Asttypes.Private
| Ast_412.Asttypes.Public -> Ast_411.Asttypes.Public
and copy_out_rec_status :
Ast_412.Outcometree.out_rec_status -> Ast_411.Outcometree.out_rec_status =
function
| Ast_412.Outcometree.Orec_not -> Ast_411.Outcometree.Orec_not
| Ast_412.Outcometree.Orec_first -> Ast_411.Outcometree.Orec_first
| Ast_412.Outcometree.Orec_next -> Ast_411.Outcometree.Orec_next
and copy_out_class_type :
Ast_412.Outcometree.out_class_type -> Ast_411.Outcometree.out_class_type =
function
| Ast_412.Outcometree.Octy_constr (x0, x1) ->
Ast_411.Outcometree.Octy_constr
((copy_out_ident x0), (List.map copy_out_type x1))
| Ast_412.Outcometree.Octy_arrow (x0, x1, x2) ->
Ast_411.Outcometree.Octy_arrow
(x0, (copy_out_type x1), (copy_out_class_type x2))
| Ast_412.Outcometree.Octy_signature (x0, x1) ->
Ast_411.Outcometree.Octy_signature
((Option.map copy_out_type x0),
(List.map copy_out_class_sig_item x1))
and copy_out_class_sig_item :
Ast_412.Outcometree.out_class_sig_item ->
Ast_411.Outcometree.out_class_sig_item
=
function
| Ast_412.Outcometree.Ocsg_constraint (x0, x1) ->
Ast_411.Outcometree.Ocsg_constraint
((copy_out_type x0), (copy_out_type x1))
| Ast_412.Outcometree.Ocsg_method (x0, x1, x2, x3) ->
Ast_411.Outcometree.Ocsg_method (x0, x1, x2, (copy_out_type x3))
| Ast_412.Outcometree.Ocsg_value (x0, x1, x2, x3) ->
Ast_411.Outcometree.Ocsg_value (x0, x1, x2, (copy_out_type x3))
and copy_out_type_param : Ast_412.Outcometree.out_type_param -> string * (bool * bool) =
function (str, (v,inj)) ->
(match inj with
| Ast_412.Asttypes.NoInjectivity -> ()
| Ast_412.Asttypes.Injective ->
(* ignoring [Injective] is not quite correct *)
()
);
let co, cn =
match v with
| Ast_412.Asttypes.Covariant -> (true, false)
| Ast_412.Asttypes.Contravariant -> (false, true)
| Ast_412.Asttypes.NoVariance -> (false, false)
in
str, (co, cn)
and copy_variance : Ast_412.Asttypes.variance -> Ast_411.Asttypes.variance =
function
| Ast_412.Asttypes.Covariant -> Ast_411.Asttypes.Covariant
| Ast_412.Asttypes.Contravariant -> Ast_411.Asttypes.Contravariant
| Ast_412.Asttypes.NoVariance -> Ast_411.Asttypes.Invariant
and copy_out_type :
Ast_412.Outcometree.out_type -> Ast_411.Outcometree.out_type =
function
| Ast_412.Outcometree.Otyp_abstract -> Ast_411.Outcometree.Otyp_abstract
| Ast_412.Outcometree.Otyp_open -> Ast_411.Outcometree.Otyp_open
| Ast_412.Outcometree.Otyp_alias (x0, x1) ->
Ast_411.Outcometree.Otyp_alias ((copy_out_type x0), x1)
| Ast_412.Outcometree.Otyp_arrow (x0, x1, x2) ->
Ast_411.Outcometree.Otyp_arrow
(x0, (copy_out_type x1), (copy_out_type x2))
| Ast_412.Outcometree.Otyp_class (x0, x1, x2) ->
Ast_411.Outcometree.Otyp_class
(x0, (copy_out_ident x1), (List.map copy_out_type x2))
| Ast_412.Outcometree.Otyp_constr (x0, x1) ->
Ast_411.Outcometree.Otyp_constr
((copy_out_ident x0), (List.map copy_out_type x1))
| Ast_412.Outcometree.Otyp_manifest (x0, x1) ->
Ast_411.Outcometree.Otyp_manifest
((copy_out_type x0), (copy_out_type x1))
| Ast_412.Outcometree.Otyp_object (x0, x1) ->
Ast_411.Outcometree.Otyp_object
((List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1))) x0),
(Option.map (fun x -> x) x1))
| Ast_412.Outcometree.Otyp_record x0 ->
Ast_411.Outcometree.Otyp_record
(List.map
(fun x -> let (x0, x1, x2) = x in (x0, x1, (copy_out_type x2))) x0)
| Ast_412.Outcometree.Otyp_stuff x0 -> Ast_411.Outcometree.Otyp_stuff x0
| Ast_412.Outcometree.Otyp_sum x0 ->
Ast_411.Outcometree.Otyp_sum
(List.map
(fun x ->
let (x0, x1, x2) = x in
(x0, (List.map copy_out_type x1),
(Option.map copy_out_type x2))) x0)
| Ast_412.Outcometree.Otyp_tuple x0 ->
Ast_411.Outcometree.Otyp_tuple (List.map copy_out_type x0)
| Ast_412.Outcometree.Otyp_var (x0, x1) ->
Ast_411.Outcometree.Otyp_var (x0, x1)
| Ast_412.Outcometree.Otyp_variant (x0, x1, x2, x3) ->
Ast_411.Outcometree.Otyp_variant
(x0, (copy_out_variant x1), x2,
(Option.map (fun x -> List.map (fun x -> x) x) x3))
| Ast_412.Outcometree.Otyp_poly (x0, x1) ->
Ast_411.Outcometree.Otyp_poly
((List.map (fun x -> x) x0), (copy_out_type x1))
| Ast_412.Outcometree.Otyp_module (x0, x1, x2) ->
Ast_411.Outcometree.Otyp_module
((copy_out_ident x0), (List.map (fun x -> x) x1),
(List.map copy_out_type x2))
| Ast_412.Outcometree.Otyp_attribute (x0, x1) ->
Ast_411.Outcometree.Otyp_attribute
((copy_out_type x0), (copy_out_attribute x1))
and copy_out_attribute :
Ast_412.Outcometree.out_attribute -> Ast_411.Outcometree.out_attribute =
fun { Ast_412.Outcometree.oattr_name = oattr_name } ->
{ Ast_411.Outcometree.oattr_name = oattr_name }
and copy_out_variant :
Ast_412.Outcometree.out_variant -> Ast_411.Outcometree.out_variant =
function
| Ast_412.Outcometree.Ovar_fields x0 ->
Ast_411.Outcometree.Ovar_fields
(List.map
(fun x ->
let (x0, x1, x2) = x in (x0, x1, (List.map copy_out_type x2)))
x0)
| Ast_412.Outcometree.Ovar_typ x0 ->
Ast_411.Outcometree.Ovar_typ (copy_out_type x0)
and copy_out_value :
Ast_412.Outcometree.out_value -> Ast_411.Outcometree.out_value =
function
| Ast_412.Outcometree.Oval_array x0 ->
Ast_411.Outcometree.Oval_array (List.map copy_out_value x0)
| Ast_412.Outcometree.Oval_char x0 -> Ast_411.Outcometree.Oval_char x0
| Ast_412.Outcometree.Oval_constr (x0, x1) ->
Ast_411.Outcometree.Oval_constr
((copy_out_ident x0), (List.map copy_out_value x1))
| Ast_412.Outcometree.Oval_ellipsis -> Ast_411.Outcometree.Oval_ellipsis
| Ast_412.Outcometree.Oval_float x0 -> Ast_411.Outcometree.Oval_float x0
| Ast_412.Outcometree.Oval_int x0 -> Ast_411.Outcometree.Oval_int x0
| Ast_412.Outcometree.Oval_int32 x0 -> Ast_411.Outcometree.Oval_int32 x0
| Ast_412.Outcometree.Oval_int64 x0 -> Ast_411.Outcometree.Oval_int64 x0
| Ast_412.Outcometree.Oval_nativeint x0 ->
Ast_411.Outcometree.Oval_nativeint x0
| Ast_412.Outcometree.Oval_list x0 ->
Ast_411.Outcometree.Oval_list (List.map copy_out_value x0)
| Ast_412.Outcometree.Oval_printer x0 ->
Ast_411.Outcometree.Oval_printer x0
| Ast_412.Outcometree.Oval_record x0 ->
Ast_411.Outcometree.Oval_record
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_ident x0), (copy_out_value x1)))
x0)
| Ast_412.Outcometree.Oval_string (x0, x1, x2) ->
Ast_411.Outcometree.Oval_string (x0, x1, (copy_out_string x2))
| Ast_412.Outcometree.Oval_stuff x0 -> Ast_411.Outcometree.Oval_stuff x0
| Ast_412.Outcometree.Oval_tuple x0 ->
Ast_411.Outcometree.Oval_tuple (List.map copy_out_value x0)
| Ast_412.Outcometree.Oval_variant (x0, x1) ->
Ast_411.Outcometree.Oval_variant (x0, (Option.map copy_out_value x1))
and copy_out_string :
Ast_412.Outcometree.out_string -> Ast_411.Outcometree.out_string =
function
| Ast_412.Outcometree.Ostr_string -> Ast_411.Outcometree.Ostr_string
| Ast_412.Outcometree.Ostr_bytes -> Ast_411.Outcometree.Ostr_bytes
and copy_out_ident :
Ast_412.Outcometree.out_ident -> Ast_411.Outcometree.out_ident =
function
| Ast_412.Outcometree.Oide_apply (x0, x1) ->
Ast_411.Outcometree.Oide_apply
((copy_out_ident x0), (copy_out_ident x1))
| Ast_412.Outcometree.Oide_dot (x0, x1) ->
Ast_411.Outcometree.Oide_dot ((copy_out_ident x0), x1)
| Ast_412.Outcometree.Oide_ident x0 ->
Ast_411.Outcometree.Oide_ident (copy_out_name x0)
and copy_out_name :
Ast_412.Outcometree.out_name -> Ast_411.Outcometree.out_name =
fun { Ast_412.Outcometree.printed_name = printed_name } ->
{ Ast_411.Outcometree.printed_name = printed_name }
================================================
FILE: src/vendored-omp/src/migrate_parsetree_412_413.ml
================================================
(**************************************************************************)
(* *)
(* OCaml Migrate Parsetree *)
(* *)
(* Frédéric Bour *)
(* *)
(* Copyright 2017 Institut National de Recherche en Informatique et *)
(* en Automatique (INRIA). *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
include Migrate_parsetree_412_413_migrate
================================================
FILE: src/vendored-omp/src/migrate_parsetree_412_413_migrate.ml
================================================
open Stdlib0
module From = Ast_412
module To = Ast_413
let rec copy_out_type_extension :
Ast_412.Outcometree.out_type_extension ->
Ast_413.Outcometree.out_type_extension
=
fun
{ Ast_412.Outcometree.otyext_name = otyext_name;
Ast_412.Outcometree.otyext_params = otyext_params;
Ast_412.Outcometree.otyext_constructors = otyext_constructors;
Ast_412.Outcometree.otyext_private = otyext_private }
->
{
Ast_413.Outcometree.otyext_name = otyext_name;
Ast_413.Outcometree.otyext_params =
(List.map (fun x -> x) otyext_params);
Ast_413.Outcometree.otyext_constructors =
(List.map
(fun x ->
let (x0, x1, x2) = x in
(x0, (List.map copy_out_type x1),
(Option.map copy_out_type x2))) otyext_constructors);
Ast_413.Outcometree.otyext_private = (copy_private_flag otyext_private)
}
and copy_out_phrase :
Ast_412.Outcometree.out_phrase -> Ast_413.Outcometree.out_phrase =
function
| Ast_412.Outcometree.Ophr_eval (x0, x1) ->
Ast_413.Outcometree.Ophr_eval ((copy_out_value x0), (copy_out_type x1))
| Ast_412.Outcometree.Ophr_signature x0 ->
Ast_413.Outcometree.Ophr_signature
(List.map
(fun x ->
let (x0, x1) = x in
((copy_out_sig_item x0), (Option.map copy_out_value x1))) x0)
| Ast_412.Outcometree.Ophr_exception x0 ->
Ast_413.Outcometree.Ophr_exception
(let (x0, x1) = x0 in (x0, (copy_out_value x1)))
and copy_out_sig_item :
Ast_412.Outcometree.out_sig_item -> Ast_413.Outcometree.out_sig_item =
function
| Ast_412.Outcometree.Osig_class (x0, x1, x2, x3, x4) ->
Ast_413.Outcometree.Osig_class
(x0, x1, (List.map copy_out_type_param x2), (copy_out_class_type x3),
(copy_out_rec_status x4))
| Ast_412.Outcometree.Osig_class_type (x0, x1, x2, x3, x4) ->
Ast_413.Outcometree.Osig_class_type
(x0, x1, (List.map copy_out_type_param x2), (copy_out_class_type x3),
(copy_out_rec_status x4))
| Ast_412.Outcometree.Osig_typext (x0, x1) ->
Ast_413.Outcometree.Osig_typext
((copy_out_extension_constructor x0), (copy_out_ext_status x1))
| Ast_412.Outcometree.Osig_modtype (x0, x1) ->
Ast_413.Outcometree.Osig_modtype (x0, (copy_out_module_type x1))
| Ast_412.Outcometree.Osig_module (x0, x1, x2) ->
Ast_413.Outcometree.Osig_module
(x0, (copy_out_module_type x1), (copy_out_rec_status x2))
| Ast_412.Outcometree.Osig_type (x0, x1) ->
Ast_413.Outcometree.Osig_type
((copy_out_type_decl x0), (copy_out_rec_status x1))
| Ast_412.Outcometree.Osig_value x0 ->
Ast_413.Outcometree.Osig_value (copy_out_val_decl x0)
| Ast_412.Outcometree.Osig_ellipsis -> Ast_413.Outcometree.Osig_ellipsis
and copy_out_val_decl :
Ast_412.Outcometree.out_val_decl -> Ast_413.Outcometree.out_val_decl =
fun
{ Ast_412.Outcometree.oval_name = oval_name;
Ast_412.Outcometree.oval_type = oval_type;
Ast_412.Outcometree.oval_prims = oval_prims;
Ast_412.Outcometree.oval_attributes = oval_attributes }
->
{
Ast_413.Outcometree.oval_name = oval_name;
Ast_413.Outcometree.oval_type = (copy_out_type oval_type);
Ast_413.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims);
Ast_413.Outcometree.oval_attributes =
(List.map copy_out_attribute oval_attributes)
}
and copy_out_type_decl :
Ast_412.Outcometree.out_type_decl -> Ast_413.Outcometree.out_type_decl =
fun
{ Ast_412.Outcometree.otype_name = otype_name;
Ast_412.Outcometree.otype_params = otype_params;
Ast_412.Outcometree.otype_type = otype_type;
Ast_412.Outcometree.otype_private = otype_private;
Ast_412.Outcometree.otype_immediate = otype_immediate;
Ast_412.Outcometree.otype_unboxed = otype_unboxed;
Ast_412.Outcometree.otype_cstrs = otype_cstrs }
->
{
Ast_413.Outcometree.otype_name = otype_name;
Ast_413.Outcometree.otype_params =
(List.map copy_out_type_param otype_params);
Ast_413.Outcometree.otype_type = (copy_out_type otype_type);
Ast_413.Outcometree.otype_private = (copy_private_flag otype_private);
Ast_413.Outcometree.otype_immediate =
(copy_Type_immediacy_t otype_immediate);
Ast_413.Outcometree.otype_unboxed = otype_unboxed;
Ast_413.Outcometree.otype_cstrs =
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_type x0), (copy_out_type x1)))
otype_cstrs)
}
and copy_Type_immediacy_t :
Ast_412.Type_immediacy.t -> Ast_413.Type_immediacy.t =
function
| Ast_412.Type_immediacy.Unknown -> Ast_413.Type_immediacy.Unknown
| Ast_412.Type_immediacy.Always -> Ast_413.Type_immediacy.Always
| Ast_412.Type_immediacy.Always_on_64bits ->
Ast_413.Type_immediacy.Always_on_64bits
and copy_out_module_type :
Ast_412.Outcometree.out_module_type -> Ast_413.Outcometree.out_module_type
=
function
| Ast_412.Outcometree.Omty_abstract -> Ast_413.Outcometree.Omty_abstract
| Ast_412.Outcometree.Omty_functor (x0, x1) ->
Ast_413.Outcometree.Omty_functor
((Option.map
(fun x ->
let (x0, x1) = x in
((Option.map (fun x -> x) x0), (copy_out_module_type x1))) x0),
(copy_out_module_type x1))
| Ast_412.Outcometree.Omty_ident x0 ->
Ast_413.Outcometree.Omty_ident (copy_out_ident x0)
| Ast_412.Outcometree.Omty_signature x0 ->
Ast_413.Outcometree.Omty_signature (List.map copy_out_sig_item x0)
| Ast_412.Outcometree.Omty_alias x0 ->
Ast_413.Outcometree.Omty_alias (copy_out_ident x0)
and copy_out_ext_status :
Ast_412.Outcometree.out_ext_status -> Ast_413.Outcometree.out_ext_status =
function
| Ast_412.Outcometree.Oext_first -> Ast_413.Outcometree.Oext_first
| Ast_412.Outcometree.Oext_next -> Ast_413.Outcometree.Oext_next
| Ast_412.Outcometree.Oext_exception -> Ast_413.Outcometree.Oext_exception
and copy_out_extension_constructor :
Ast_412.Outcometree.out_extension_constructor ->
Ast_413.Outcometree.out_extension_constructor
=
fun
{ Ast_412.Outcometree.oext_name = oext_name;
Ast_412.Outcometree.oext_type_name = oext_type_name;
Ast_412.Outcometree.oext_type_params = oext_type_params;
Ast_412.Outcometree.oext_args = oext_args;
Ast_412.Outcometree.oext_ret_type = oext_ret_type;
Ast_412.Outcometree.oext_private = oext_private }
->
{
Ast_413.Outcometree.oext_name = oext_name;
Ast_413.Outcometree.oext_type_name = oext_type_name;
Ast_413.Outcometree.oext_type_params =
(List.map (fun x -> x) oext_type_params);
Ast_413.Outcometree.oext_args = (List.map copy_out_type oext_args);
Ast_413.Outcometree.oext_ret_type =
(Option.map copy_out_type oext_ret_type);
Ast_413.Outcometree.oext_private = (copy_private_flag oext_private)
}
and copy_private_flag :
Ast_412.Asttypes.private_flag -> Ast_413.Asttypes.private_flag =
function
| Ast_412.Asttypes.Private -> Ast_413.Asttypes.Private
| Ast_412.Asttypes.Public -> Ast_413.Asttypes.Public
and copy_out_rec_status :
Ast_412.Outcometree.out_rec_status -> Ast_413.Outcometree.out_rec_status =
function
| Ast_412.Outcometree.Orec_not -> Ast_413.Outcometree.Orec_not
| Ast_412.Outcometree.Orec_first -> Ast_413.Outcometree.Orec_first
| Ast_412.Outcometree.Orec_next -> Ast_413.Outcometree.Orec_next
and copy_out_class_type :
Ast_412.Outcometree.out_class_type -> Ast_413.Outcometree.out_class_type =
function
| Ast_412.Outcometree.Octy_constr (x0, x1) ->
Ast_413.Outcometree.Octy_constr
((copy_out_ident x0), (List.map copy_out_type x1))
| Ast_412.Outcometree.Octy_arrow (x0, x1, x2) ->
Ast_413.Outcometree.Octy_arrow
(x0, (copy_out_type x1), (copy_out_class_type x2))
| Ast_412.Outcometree.Octy_signature (x0, x1) ->
Ast_413.Outcometree.Octy_signature
((Option.map copy_out_type x0),
(List.map copy_out_class_sig_item x1))
and copy_out_class_sig_item :
Ast_412.Outcometree.out_class_sig_item ->
Ast_413.Outcometree.out_class_sig_item
=
function
| Ast_412.Outcometree.Ocsg_constraint (x0, x1) ->
Ast_413.Outcometree.Ocsg_constraint
((copy_out_type x0), (copy_out_type x1))
| Ast_412.Outcometree.Ocsg_method (x0, x1, x2, x3) ->
Ast_413.Outcometree.Ocsg_method (x0, x1, x2, (copy_out_type x3))
| Ast_412.Outcometree.Ocsg_value (x0, x1, x2, x3) ->
Ast_413.Outcometree.Ocsg_value (x0, x1, x2, (copy_out_type x3))
and copy_out_type_param :
Ast_412.Outcometree.out_type_param -> Ast_413.Outcometree.out_type_param =
fun x ->
let (x0, x1) = x in
(x0, (let (x0, x1) = x1 in ((copy_variance x0), (copy_injectivity x1))))
and copy_injectivity :
Ast_412.Asttypes.injectivity -> Ast_413.Asttypes.injectivity =
function
| Ast_412.Asttypes.Injective -> Ast_413.Asttypes.Injective
| Ast_412.Asttypes.NoInjectivity -> Ast_413.Asttypes.NoInjectivity
and copy_variance : Ast_412.Asttypes.variance -> Ast_413.Asttypes.variance =
function
| Ast_412.Asttypes.Covariant -> Ast_413.Asttypes.Covariant
| Ast_412.Asttypes.Contravariant -> Ast_413.Asttypes.Contravariant
| Ast_412.Asttypes.NoVariance -> Ast_413.Asttypes.NoVariance
and copy_out_type :
Ast_412.Outcometree.out_type -> Ast_413.Outcometree.out_type =
function
| Ast_412.Outcometree.Otyp_abstract -> Ast_413.Outcometree.Otyp_abstract
| Ast_412.Outcometree.Otyp_open -> Ast_413.Outcometree.Otyp_open
| Ast_412.Outcometree.Otyp_alias (x0, x1) ->
Ast_413.Outcometree.Otyp_alias ((copy_out_type x0), x1)
| Ast_412.Outcometree.Otyp_arrow (x0, x1, x2) ->
Ast_413.Outcometree.Otyp_arrow
(x0, (copy_out_type x1), (copy_out_type x2))
| Ast_412.Outcometree.Otyp_class (x0, x1, x2) ->
Ast_413.Outcometree.Otyp_class
(x0, (copy_out_ident x1), (List.map copy_out_type x2))
| Ast_412.Outcometree.Otyp_constr (x0, x1) ->
Ast_413.Outcometree.Otyp_constr
((copy_out_ident x0), (List.map copy_out_type x1))
| Ast_412.Outcometree.Otyp_manifest (x0, x1) ->
Ast_413.Outcometree.Otyp_manifest
((copy_out_type x0), (copy_out_type x1))
| Ast_412.Outcometree.Otyp_object (x0, x1) ->
Ast_413.Outcometree.Otyp_object
((List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1))) x0),
(Option.map (fun x -> x) x1))
| Ast_412.Outcometree.Otyp_record x0 ->
Ast_413.Outcometree.Otyp_record
(List.map
(fun x -> let (x0, x1, x2) = x in (x0, x1, (copy_out_type x2))) x0)
| Ast_412.Outcometree.Otyp_stuff x0 -> Ast_413.Outcometree.Otyp_stuff x0
| Ast_412.Outcometree.Otyp_sum x0 ->
Ast_413.Outcometree.Otyp_sum
(List.map
(fun x ->
let (x0, x1, x2) = x in
(x0, (List.map copy_out_type x1),
(Option.map copy_out_type x2))) x0)
| Ast_412.Outcometree.Otyp_tuple x0 ->
Ast_413.Outcometree.Otyp_tuple (List.map copy_out_type x0)
| Ast_412.Outcometree.Otyp_var (x0, x1) ->
Ast_413.Outcometree.Otyp_var (x0, x1)
| Ast_412.Outcometree.Otyp_variant (x0, x1, x2, x3) ->
Ast_413.Outcometree.Otyp_variant
(x0, (copy_out_variant x1), x2,
(Option.map (fun x -> List.map (fun x -> x) x) x3))
| Ast_412.Outcometree.Otyp_poly (x0, x1) ->
Ast_413.Outcometree.Otyp_poly
((List.map (fun x -> x) x0), (copy_out_type x1))
| Ast_412.Outcometree.Otyp_module (x0, x1, x2) ->
Ast_413.Outcometree.Otyp_module
((copy_out_ident x0), (List.map2 (fun x y -> x, copy_out_type y) x1 x2))
| Ast_412.Outcometree.Otyp_attribute (x0, x1) ->
Ast_413.Outcometree.Otyp_attribute
((copy_out_type x0), (copy_out_attribute x1))
and copy_out_attribute :
Ast_412.Outcometree.out_attribute -> Ast_413.Outcometree.out_attribute =
fun { Ast_412.Outcometree.oattr_name = oattr_name } ->
{ Ast_413.Outcometree.oattr_name = oattr_name }
and copy_out_variant :
Ast_412.Outcometree.out_variant -> Ast_413.Outcometree.out_variant =
function
| Ast_412.Outcometree.Ovar_fields x0 ->
Ast_413.Outcometree.Ovar_fields
(List.map
(fun x ->
let (x0, x1, x2) = x in (x0, x1, (List.map copy_out_type x2)))
x0)
| Ast_412.Outcometree.Ovar_typ x0 ->
Ast_413.Outcometree.Ovar_typ (copy_out_type x0)
and copy_out_value :
Ast_412.Outcometree.out_value -> Ast_413.Outcometree.out_value =
function
| Ast_412.Outcometree.Oval_array x0 ->
Ast_413.Outcometree.Oval_array (List.map copy_out_value x0)
| Ast_412.Outcometree.Oval_char x0 -> Ast_413.Outcometree.Oval_char x0
| Ast_412.Outcometree.Oval_constr (x0, x1) ->
Ast_413.Outcometree.Oval_constr
((copy_out_ident x0), (List.map copy_out_value x1))
| Ast_412.Outcometree.Oval_ellipsis -> Ast_413.Outcometree.Oval_ellipsis
| Ast_412.Outcometree.Oval_float x0 -> Ast_413.Outcometree.Oval_float x0
| Ast_412.Outcometree.Oval_int x0 -> Ast_413.Outcometree.Oval_int x0
| Ast_412.Outcometree.Oval_int32 x0 -> Ast_413.Outcometree.Oval_int32 x0
| Ast_412.Outcometree.Oval_int64 x0 -> Ast_413.Outcometree.Oval_int64 x0
| Ast_412.Outcometree.Oval_nativeint x0 ->
Ast_413.Outcometree.Oval_nativeint x0
| Ast_412.Outcometree.Oval_list x0 ->
Ast_413.Outcometree.Oval_list (List.map copy_out_value x0)
| Ast_412.Outcometree.Oval_printer x0 ->
Ast_413.Outcometree.Oval_printer x0
| Ast_412.Outcometree.Oval_record x0 ->
Ast_413.Outcometree.Oval_record
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_ident x0), (copy_out_value x1)))
x0)
| Ast_412.Outcometree.Oval_string (x0, x1, x2) ->
Ast_413.Outcometree.Oval_string (x0, x1, (copy_out_string x2))
| Ast_412.Outcometree.Oval_stuff x0 -> Ast_413.Outcometree.Oval_stuff x0
| Ast_412.Outcometree.Oval_tuple x0 ->
Ast_413.Outcometree.Oval_tuple (List.map copy_out_value x0)
| Ast_412.Outcometree.Oval_variant (x0, x1) ->
Ast_413.Outcometree.Oval_variant (x0, (Option.map copy_out_value x1))
and copy_out_string :
Ast_412.Outcometree.out_string -> Ast_413.Outcometree.out_string =
function
| Ast_412.Outcometree.Ostr_string -> Ast_413.Outcometree.Ostr_string
| Ast_412.Outcometree.Ostr_bytes -> Ast_413.Outcometree.Ostr_bytes
and copy_out_ident :
Ast_412.Outcometree.out_ident -> Ast_413.Outcometree.out_ident =
function
| Ast_412.Outcometree.Oide_apply (x0, x1) ->
Ast_413.Outcometree.Oide_apply
((copy_out_ident x0), (copy_out_ident x1))
| Ast_412.Outcometree.Oide_dot (x0, x1) ->
Ast_413.Outcometree.Oide_dot ((copy_out_ident x0), x1)
| Ast_412.Outcometree.Oide_ident x0 ->
Ast_413.Outcometree.Oide_ident (copy_out_name x0)
and copy_out_name :
Ast_412.Outcometree.out_name -> Ast_413.Outcometree.out_name =
fun { Ast_412.Outcometree.printed_name = printed_name } ->
{ Ast_413.Outcometree.printed_name = printed_name }
================================================
FILE: src/vendored-omp/src/migrate_parsetree_413_412.ml
================================================
(**************************************************************************)
(* *)
(* OCaml Migrate Parsetree *)
(* *)
(* Frédéric Bour *)
(* *)
(* Copyright 2017 Institut National de Recherche en Informatique et *)
(* en Automatique (INRIA). *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
include Migrate_parsetree_413_412_migrate
================================================
FILE: src/vendored-omp/src/migrate_parsetree_413_412_migrate.ml
================================================
open Stdlib0
module From = Ast_413
module To = Ast_412
let rec copy_out_type_extension :
Ast_413.Outcometree.out_type_extension ->
Ast_412.Outcometree.out_type_extension
=
fun
{ Ast_413.Outcometree.otyext_name = otyext_name;
Ast_413.Outcometree.otyext_params = otyext_params;
Ast_413.Outcometree.otyext_constructors = otyext_constructors;
Ast_413.Outcometree.otyext_private = otyext_private }
->
{
Ast_412.Outcometree.otyext_name = otyext_name;
Ast_412.Outcometree.otyext_params =
(List.map (fun x -> x) otyext_params);
Ast_412.Outcometree.otyext_constructors =
(List.map
(fun x ->
let (x0, x1, x2) = x in
(x0, (List.map copy_out_type x1),
(Option.map copy_out_type x2))) otyext_constructors);
Ast_412.Outcometree.otyext_private = (copy_private_flag otyext_private)
}
and copy_out_phrase :
Ast_413.Outcometree.out_phrase -> Ast_412.Outcometree.out_phrase =
function
| Ast_413.Outcometree.Ophr_eval (x0, x1) ->
Ast_412.Outcometree.Ophr_eval ((copy_out_value x0), (copy_out_type x1))
| Ast_413.Outcometree.Ophr_signature x0 ->
Ast_412.Outcometree.Ophr_signature
(List.map
(fun x ->
let (x0, x1) = x in
((copy_out_sig_item x0), (Option.map copy_out_value x1))) x0)
| Ast_413.Outcometree.Ophr_exception x0 ->
Ast_412.Outcometree.Ophr_exception
(let (x0, x1) = x0 in (x0, (copy_out_value x1)))
and copy_out_sig_item :
Ast_413.Outcometree.out_sig_item -> Ast_412.Outcometree.out_sig_item =
function
| Ast_413.Outcometree.Osig_class (x0, x1, x2, x3, x4) ->
Ast_412.Outcometree.Osig_class
(x0, x1, (List.map copy_out_type_param x2), (copy_out_class_type x3),
(copy_out_rec_status x4))
| Ast_413.Outcometree.Osig_class_type (x0, x1, x2, x3, x4) ->
Ast_412.Outcometree.Osig_class_type
(x0, x1, (List.map copy_out_type_param x2), (copy_out_class_type x3),
(copy_out_rec_status x4))
| Ast_413.Outcometree.Osig_typext (x0, x1) ->
Ast_412.Outcometree.Osig_typext
((copy_out_extension_constructor x0), (copy_out_ext_status x1))
| Ast_413.Outcometree.Osig_modtype (x0, x1) ->
Ast_412.Outcometree.Osig_modtype (x0, (copy_out_module_type x1))
| Ast_413.Outcometree.Osig_module (x0, x1, x2) ->
Ast_412.Outcometree.Osig_module
(x0, (copy_out_module_type x1), (copy_out_rec_status x2))
| Ast_413.Outcometree.Osig_type (x0, x1) ->
Ast_412.Outcometree.Osig_type
((copy_out_type_decl x0), (copy_out_rec_status x1))
| Ast_413.Outcometree.Osig_value x0 ->
Ast_412.Outcometree.Osig_value (copy_out_val_decl x0)
| Ast_413.Outcometree.Osig_ellipsis -> Ast_412.Outcometree.Osig_ellipsis
and copy_out_val_decl :
Ast_413.Outcometree.out_val_decl -> Ast_412.Outcometree.out_val_decl =
fun
{ Ast_413.Outcometree.oval_name = oval_name;
Ast_413.Outcometree.oval_type = oval_type;
Ast_413.Outcometree.oval_prims = oval_prims;
Ast_413.Outcometree.oval_attributes = oval_attributes }
->
{
Ast_412.Outcometree.oval_name = oval_name;
Ast_412.Outcometree.oval_type = (copy_out_type oval_type);
Ast_412.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims);
Ast_412.Outcometree.oval_attributes =
(List.map copy_out_attribute oval_attributes)
}
and copy_out_type_decl :
Ast_413.Outcometree.out_type_decl -> Ast_412.Outcometree.out_type_decl =
fun
{ Ast_413.Outcometree.otype_name = otype_name;
Ast_413.Outcometree.otype_params = otype_params;
Ast_413.Outcometree.otype_type = otype_type;
Ast_413.Outcometree.otype_private = otype_private;
Ast_413.Outcometree.otype_immediate = otype_immediate;
Ast_413.Outcometree.otype_unboxed = otype_unboxed;
Ast_413.Outcometree.otype_cstrs = otype_cstrs }
->
{
Ast_412.Outcometree.otype_name = otype_name;
Ast_412.Outcometree.otype_params =
(List.map copy_out_type_param otype_params);
Ast_412.Outcometree.otype_type = (copy_out_type otype_type);
Ast_412.Outcometree.otype_private = (copy_private_flag otype_private);
Ast_412.Outcometree.otype_immediate =
(copy_Type_immediacy_t otype_immediate);
Ast_412.Outcometree.otype_unboxed = otype_unboxed;
Ast_412.Outcometree.otype_cstrs =
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_type x0), (copy_out_type x1)))
otype_cstrs)
}
and copy_Type_immediacy_t :
Ast_413.Type_immediacy.t -> Ast_412.Type_immediacy.t =
function
| Ast_413.Type_immediacy.Unknown -> Ast_412.Type_immediacy.Unknown
| Ast_413.Type_immediacy.Always -> Ast_412.Type_immediacy.Always
| Ast_413.Type_immediacy.Always_on_64bits ->
Ast_412.Type_immediacy.Always_on_64bits
and copy_out_module_type :
Ast_413.Outcometree.out_module_type -> Ast_412.Outcometree.out_module_type
=
function
| Ast_413.Outcometree.Omty_abstract -> Ast_412.Outcometree.Omty_abstract
| Ast_413.Outcometree.Omty_functor (x0, x1) ->
Ast_412.Outcometree.Omty_functor
((Option.map
(fun x ->
let (x0, x1) = x in
((Option.map (fun x -> x) x0), (copy_out_module_type x1))) x0),
(copy_out_module_type x1))
| Ast_413.Outcometree.Omty_ident x0 ->
Ast_412.Outcometree.Omty_ident (copy_out_ident x0)
| Ast_413.Outcometree.Omty_signature x0 ->
Ast_412.Outcometree.Omty_signature (List.map copy_out_sig_item x0)
| Ast_413.Outcometree.Omty_alias x0 ->
Ast_412.Outcometree.Omty_alias (copy_out_ident x0)
and copy_out_ext_status :
Ast_413.Outcometree.out_ext_status -> Ast_412.Outcometree.out_ext_status =
function
| Ast_413.Outcometree.Oext_first -> Ast_412.Outcometree.Oext_first
| Ast_413.Outcometree.Oext_next -> Ast_412.Outcometree.Oext_next
| Ast_413.Outcometree.Oext_exception -> Ast_412.Outcometree.Oext_exception
and copy_out_extension_constructor :
Ast_413.Outcometree.out_extension_constructor ->
Ast_412.Outcometree.out_extension_constructor
=
fun
{ Ast_413.Outcometree.oext_name = oext_name;
Ast_413.Outcometree.oext_type_name = oext_type_name;
Ast_413.Outcometree.oext_type_params = oext_type_params;
Ast_413.Outcometree.oext_args = oext_args;
Ast_413.Outcometree.oext_ret_type = oext_ret_type;
Ast_413.Outcometree.oext_private = oext_private }
->
{
Ast_412.Outcometree.oext_name = oext_name;
Ast_412.Outcometree.oext_type_name = oext_type_name;
Ast_412.Outcometree.oext_type_params =
(List.map (fun x -> x) oext_type_params);
Ast_412.Outcometree.oext_args = (List.map copy_out_type oext_args);
Ast_412.Outcometree.oext_ret_type =
(Option.map copy_out_type oext_ret_type);
Ast_412.Outcometree.oext_private = (copy_private_flag oext_private)
}
and copy_private_flag :
Ast_413.Asttypes.private_flag -> Ast_412.Asttypes.private_flag =
function
| Ast_413.Asttypes.Private -> Ast_412.Asttypes.Private
| Ast_413.Asttypes.Public -> Ast_412.Asttypes.Public
and copy_out_rec_status :
Ast_413.Outcometree.out_rec_status -> Ast_412.Outcometree.out_rec_status =
function
| Ast_413.Outcometree.Orec_not -> Ast_412.Outcometree.Orec_not
| Ast_413.Outcometree.Orec_first -> Ast_412.Outcometree.Orec_first
| Ast_413.Outcometree.Orec_next -> Ast_412.Outcometree.Orec_next
and copy_out_class_type :
Ast_413.Outcometree.out_class_type -> Ast_412.Outcometree.out_class_type =
function
| Ast_413.Outcometree.Octy_constr (x0, x1) ->
Ast_412.Outcometree.Octy_constr
((copy_out_ident x0), (List.map copy_out_type x1))
| Ast_413.Outcometree.Octy_arrow (x0, x1, x2) ->
Ast_412.Outcometree.Octy_arrow
(x0, (copy_out_type x1), (copy_out_class_type x2))
| Ast_413.Outcometree.Octy_signature (x0, x1) ->
Ast_412.Outcometree.Octy_signature
((Option.map copy_out_type x0),
(List.map copy_out_class_sig_item x1))
and copy_out_class_sig_item :
Ast_413.Outcometree.out_class_sig_item ->
Ast_412.Outcometree.out_class_sig_item
=
function
| Ast_413.Outcometree.Ocsg_constraint (x0, x1) ->
Ast_412.Outcometree.Ocsg_constraint
((copy_out_type x0), (copy_out_type x1))
| Ast_413.Outcometree.Ocsg_method (x0, x1, x2, x3) ->
Ast_412.Outcometree.Ocsg_method (x0, x1, x2, (copy_out_type x3))
| Ast_413.Outcometree.Ocsg_value (x0, x1, x2, x3) ->
Ast_412.Outcometree.Ocsg_value (x0, x1, x2, (copy_out_type x3))
and copy_out_type_param :
Ast_413.Outcometree.out_type_param -> Ast_412.Outcometree.out_type_param =
fun x ->
let (x0, x1) = x in
(x0, (let (x0, x1) = x1 in ((copy_variance x0), (copy_injectivity x1))))
and copy_injectivity :
Ast_413.Asttypes.injectivity -> Ast_412.Asttypes.injectivity =
function
| Ast_413.Asttypes.Injective -> Ast_412.Asttypes.Injective
| Ast_413.Asttypes.NoInjectivity -> Ast_412.Asttypes.NoInjectivity
and copy_variance : Ast_413.Asttypes.variance -> Ast_412.Asttypes.variance =
function
| Ast_413.Asttypes.Covariant -> Ast_412.Asttypes.Covariant
| Ast_413.Asttypes.Contravariant -> Ast_412.Asttypes.Contravariant
| Ast_413.Asttypes.NoVariance -> Ast_412.Asttypes.NoVariance
and copy_out_type :
Ast_413.Outcometree.out_type -> Ast_412.Outcometree.out_type =
function
| Ast_413.Outcometree.Otyp_abstract -> Ast_412.Outcometree.Otyp_abstract
| Ast_413.Outcometree.Otyp_open -> Ast_412.Outcometree.Otyp_open
| Ast_413.Outcometree.Otyp_alias (x0, x1) ->
Ast_412.Outcometree.Otyp_alias ((copy_out_type x0), x1)
| Ast_413.Outcometree.Otyp_arrow (x0, x1, x2) ->
Ast_412.Outcometree.Otyp_arrow
(x0, (copy_out_type x1), (copy_out_type x2))
| Ast_413.Outcometree.Otyp_class (x0, x1, x2) ->
Ast_412.Outcometree.Otyp_class
(x0, (copy_out_ident x1), (List.map copy_out_type x2))
| Ast_413.Outcometree.Otyp_constr (x0, x1) ->
Ast_412.Outcometree.Otyp_constr
((copy_out_ident x0), (List.map copy_out_type x1))
| Ast_413.Outcometree.Otyp_manifest (x0, x1) ->
Ast_412.Outcometree.Otyp_manifest
((copy_out_type x0), (copy_out_type x1))
| Ast_413.Outcometree.Otyp_object (x0, x1) ->
Ast_412.Outcometree.Otyp_object
((List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1))) x0),
(Option.map (fun x -> x) x1))
| Ast_413.Outcometree.Otyp_record x0 ->
Ast_412.Outcometree.Otyp_record
(List.map
(fun x -> let (x0, x1, x2) = x in (x0, x1, (copy_out_type x2))) x0)
| Ast_413.Outcometree.Otyp_stuff x0 -> Ast_412.Outcometree.Otyp_stuff x0
| Ast_413.Outcometree.Otyp_sum x0 ->
Ast_412.Outcometree.Otyp_sum
(List.map
(fun x ->
let (x0, x1, x2) = x in
(x0, (List.map copy_out_type x1),
(Option.map copy_out_type x2))) x0)
| Ast_413.Outcometree.Otyp_tuple x0 ->
Ast_412.Outcometree.Otyp_tuple (List.map copy_out_type x0)
| Ast_413.Outcometree.Otyp_var (x0, x1) ->
Ast_412.Outcometree.Otyp_var (x0, x1)
| Ast_413.Outcometree.Otyp_variant (x0, x1, x2, x3) ->
Ast_412.Outcometree.Otyp_variant
(x0, (copy_out_variant x1), x2,
(Option.map (fun x -> List.map (fun x -> x) x) x3))
| Ast_413.Outcometree.Otyp_poly (x0, x1) ->
Ast_412.Outcometree.Otyp_poly
((List.map (fun x -> x) x0), (copy_out_type x1))
| Ast_413.Outcometree.Otyp_module (x0, x1) ->
Ast_412.Outcometree.Otyp_module
((copy_out_ident x0),
(List.map fst x1),
(List.map (fun (_, x) -> (copy_out_type x)) x1))
| Ast_413.Outcometree.Otyp_attribute (x0, x1) ->
Ast_412.Outcometree.Otyp_attribute
((copy_out_type x0), (copy_out_attribute x1))
and copy_out_attribute :
Ast_413.Outcometree.out_attribute -> Ast_412.Outcometree.out_attribute =
fun { Ast_413.Outcometree.oattr_name = oattr_name } ->
{ Ast_412.Outcometree.oattr_name = oattr_name }
and copy_out_variant :
Ast_413.Outcometree.out_variant -> Ast_412.Outcometree.out_variant =
function
| Ast_413.Outcometree.Ovar_fields x0 ->
Ast_412.Outcometree.Ovar_fields
(List.map
(fun x ->
let (x0, x1, x2) = x in (x0, x1, (List.map copy_out_type x2)))
x0)
| Ast_413.Outcometree.Ovar_typ x0 ->
Ast_412.Outcometree.Ovar_typ (copy_out_type x0)
and copy_out_value :
Ast_413.Outcometree.out_value -> Ast_412.Outcometree.out_value =
function
| Ast_413.Outcometree.Oval_array x0 ->
Ast_412.Outcometree.Oval_array (List.map copy_out_value x0)
| Ast_413.Outcometree.Oval_char x0 -> Ast_412.Outcometree.Oval_char x0
| Ast_413.Outcometree.Oval_constr (x0, x1) ->
Ast_412.Outcometree.Oval_constr
((copy_out_ident x0), (List.map copy_out_value x1))
| Ast_413.Outcometree.Oval_ellipsis -> Ast_412.Outcometree.Oval_ellipsis
| Ast_413.Outcometree.Oval_float x0 -> Ast_412.Outcometree.Oval_float x0
| Ast_413.Outcometree.Oval_int x0 -> Ast_412.Outcometree.Oval_int x0
| Ast_413.Outcometree.Oval_int32 x0 -> Ast_412.Outcometree.Oval_int32 x0
| Ast_413.Outcometree.Oval_int64 x0 -> Ast_412.Outcometree.Oval_int64 x0
| Ast_413.Outcometree.Oval_nativeint x0 ->
Ast_412.Outcometree.Oval_nativeint x0
| Ast_413.Outcometree.Oval_list x0 ->
Ast_412.Outcometree.Oval_list (List.map copy_out_value x0)
| Ast_413.Outcometree.Oval_printer x0 ->
Ast_412.Outcometree.Oval_printer x0
| Ast_413.Outcometree.Oval_record x0 ->
Ast_412.Outcometree.Oval_record
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_ident x0), (copy_out_value x1)))
x0)
| Ast_413.Outcometree.Oval_string (x0, x1, x2) ->
Ast_412.Outcometree.Oval_string (x0, x1, (copy_out_string x2))
| Ast_413.Outcometree.Oval_stuff x0 -> Ast_412.Outcometree.Oval_stuff x0
| Ast_413.Outcometree.Oval_tuple x0 ->
Ast_412.Outcometree.Oval_tuple (List.map copy_out_value x0)
| Ast_413.Outcometree.Oval_variant (x0, x1) ->
Ast_412.Outcometree.Oval_variant (x0, (Option.map copy_out_value x1))
and copy_out_string :
Ast_413.Outcometree.out_string -> Ast_412.Outcometree.out_string =
function
| Ast_413.Outcometree.Ostr_string -> Ast_412.Outcometree.Ostr_string
| Ast_413.Outcometree.Ostr_bytes -> Ast_412.Outcometree.Ostr_bytes
and copy_out_ident :
Ast_413.Outcometree.out_ident -> Ast_412.Outcometree.out_ident =
function
| Ast_413.Outcometree.Oide_apply (x0, x1) ->
Ast_412.Outcometree.Oide_apply
((copy_out_ident x0), (copy_out_ident x1))
| Ast_413.Outcometree.Oide_dot (x0, x1) ->
Ast_412.Outcometree.Oide_dot ((copy_out_ident x0), x1)
| Ast_413.Outcometree.Oide_ident x0 ->
Ast_412.Outcometree.Oide_ident (copy_out_name x0)
and copy_out_name :
Ast_413.Outcometree.out_name -> Ast_412.Outcometree.out_name =
fun { Ast_413.Outcometree.printed_name = printed_name } ->
{ Ast_412.Outcometree.printed_name = printed_name }
================================================
FILE: src/vendored-omp/src/migrate_parsetree_413_414.ml
================================================
(**************************************************************************)
(* *)
(* OCaml Migrate Parsetree *)
(* *)
(* Frédéric Bour *)
(* *)
(* Copyright 2017 Institut National de Recherche en Informatique et *)
(* en Automatique (INRIA). *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
include Migrate_parsetree_413_414_migrate
================================================
FILE: src/vendored-omp/src/migrate_parsetree_413_414_migrate.ml
================================================
open Stdlib0
module From = Ast_413
module To = Ast_414
let rec copy_out_type_extension :
Ast_413.Outcometree.out_type_extension ->
Ast_414.Outcometree.out_type_extension
=
fun
{ Ast_413.Outcometree.otyext_name = otyext_name;
Ast_413.Outcometree.otyext_params = otyext_params;
Ast_413.Outcometree.otyext_constructors = otyext_constructors;
Ast_413.Outcometree.otyext_private = otyext_private }
->
{
Ast_414.Outcometree.otyext_name = otyext_name;
Ast_414.Outcometree.otyext_params =
(List.map (fun x -> x) otyext_params);
Ast_414.Outcometree.otyext_constructors =
(List.map
(fun x ->
let (x0, x1, x2) = x in
let x1 = (List.map copy_out_type x1) in
let x2 = (Option.map copy_out_type x2) in
Ast_414.Outcometree.{ ocstr_name = x0; ocstr_args = x1; ocstr_return_type = x2 })
otyext_constructors);
Ast_414.Outcometree.otyext_private = (copy_private_flag otyext_private)
}
and copy_out_phrase :
Ast_413.Outcometree.out_phrase -> Ast_414.Outcometree.out_phrase =
function
| Ast_413.Outcometree.Ophr_eval (x0, x1) ->
Ast_414.Outcometree.Ophr_eval ((copy_out_value x0), (copy_out_type x1))
| Ast_413.Outcometree.Ophr_signature x0 ->
Ast_414.Outcometree.Ophr_signature
(List.map
(fun x ->
let (x0, x1) = x in
((copy_out_sig_item x0), (Option.map copy_out_value x1))) x0)
| Ast_413.Outcometree.Ophr_exception x0 ->
Ast_414.Outcometree.Ophr_exception
(let (x0, x1) = x0 in (x0, (copy_out_value x1)))
and copy_out_sig_item :
Ast_413.Outcometree.out_sig_item -> Ast_414.Outcometree.out_sig_item =
function
| Ast_413.Outcometree.Osig_class (x0, x1, x2, x3, x4) ->
Ast_414.Outcometree.Osig_class
(x0, x1, (List.map copy_out_type_param x2), (copy_out_class_type x3),
(copy_out_rec_status x4))
| Ast_413.Outcometree.Osig_class_type (x0, x1, x2, x3, x4) ->
Ast_414.Outcometree.Osig_class_type
(x0, x1, (List.map copy_out_type_param x2), (copy_out_class_type x3),
(copy_out_rec_status x4))
| Ast_413.Outcometree.Osig_typext (x0, x1) ->
Ast_414.Outcometree.Osig_typext
((copy_out_extension_constructor x0), (copy_out_ext_status x1))
| Ast_413.Outcometree.Osig_modtype (x0, x1) ->
Ast_414.Outcometree.Osig_modtype (x0, (copy_out_module_type x1))
| Ast_413.Outcometree.Osig_module (x0, x1, x2) ->
Ast_414.Outcometree.Osig_module
(x0, (copy_out_module_type x1), (copy_out_rec_status x2))
| Ast_413.Outcometree.Osig_type (x0, x1) ->
Ast_414.Outcometree.Osig_type
((copy_out_type_decl x0), (copy_out_rec_status x1))
| Ast_413.Outcometree.Osig_value x0 ->
Ast_414.Outcometree.Osig_value (copy_out_val_decl x0)
| Ast_413.Outcometree.Osig_ellipsis -> Ast_414.Outcometree.Osig_ellipsis
and copy_out_val_decl :
Ast_413.Outcometree.out_val_decl -> Ast_414.Outcometree.out_val_decl =
fun
{ Ast_413.Outcometree.oval_name = oval_name;
Ast_413.Outcometree.oval_type = oval_type;
Ast_413.Outcometree.oval_prims = oval_prims;
Ast_413.Outcometree.oval_attributes = oval_attributes }
->
{
Ast_414.Outcometree.oval_name = oval_name;
Ast_414.Outcometree.oval_type = (copy_out_type oval_type);
Ast_414.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims);
Ast_414.Outcometree.oval_attributes =
(List.map copy_out_attribute oval_attributes)
}
and copy_out_type_decl :
Ast_413.Outcometree.out_type_decl -> Ast_414.Outcometree.out_type_decl =
fun
{ Ast_413.Outcometree.otype_name = otype_name;
Ast_413.Outcometree.otype_params = otype_params;
Ast_413.Outcometree.otype_type = otype_type;
Ast_413.Outcometree.otype_private = otype_private;
Ast_413.Outcometree.otype_immediate = otype_immediate;
Ast_413.Outcometree.otype_unboxed = otype_unboxed;
Ast_413.Outcometree.otype_cstrs = otype_cstrs }
->
{
Ast_414.Outcometree.otype_name = otype_name;
Ast_414.Outcometree.otype_params =
(List.map copy_out_type_param otype_params);
Ast_414.Outcometree.otype_type = (copy_out_type otype_type);
Ast_414.Outcometree.otype_private = (copy_private_flag otype_private);
Ast_414.Outcometree.otype_immediate =
(copy_Type_immediacy_t otype_immediate);
Ast_414.Outcometree.otype_unboxed = otype_unboxed;
Ast_414.Outcometree.otype_cstrs =
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_type x0), (copy_out_type x1)))
otype_cstrs)
}
and copy_Type_immediacy_t :
Ast_413.Type_immediacy.t -> Ast_414.Type_immediacy.t =
function
| Ast_413.Type_immediacy.Unknown -> Ast_414.Type_immediacy.Unknown
| Ast_413.Type_immediacy.Always -> Ast_414.Type_immediacy.Always
| Ast_413.Type_immediacy.Always_on_64bits ->
Ast_414.Type_immediacy.Always_on_64bits
and copy_out_module_type :
Ast_413.Outcometree.out_module_type -> Ast_414.Outcometree.out_module_type
=
function
| Ast_413.Outcometree.Omty_abstract -> Ast_414.Outcometree.Omty_abstract
| Ast_413.Outcometree.Omty_functor (x0, x1) ->
Ast_414.Outcometree.Omty_functor
((Option.map
(fun x ->
let (x0, x1) = x in
((Option.map (fun x -> x) x0), (copy_out_module_type x1))) x0),
(copy_out_module_type x1))
| Ast_413.Outcometree.Omty_ident x0 ->
Ast_414.Outcometree.Omty_ident (copy_out_ident x0)
| Ast_413.Outcometree.Omty_signature x0 ->
Ast_414.Outcometree.Omty_signature (List.map copy_out_sig_item x0)
| Ast_413.Outcometree.Omty_alias x0 ->
Ast_414.Outcometree.Omty_alias (copy_out_ident x0)
and copy_out_ext_status :
Ast_413.Outcometree.out_ext_status -> Ast_414.Outcometree.out_ext_status =
function
| Ast_413.Outcometree.Oext_first -> Ast_414.Outcometree.Oext_first
| Ast_413.Outcometree.Oext_next -> Ast_414.Outcometree.Oext_next
| Ast_413.Outcometree.Oext_exception -> Ast_414.Outcometree.Oext_exception
and copy_out_extension_constructor :
Ast_413.Outcometree.out_extension_constructor ->
Ast_414.Outcometree.out_extension_constructor
=
fun
{ Ast_413.Outcometree.oext_name = oext_name;
Ast_413.Outcometree.oext_type_name = oext_type_name;
Ast_413.Outcometree.oext_type_params = oext_type_params;
Ast_413.Outcometree.oext_args = oext_args;
Ast_413.Outcometree.oext_ret_type = oext_ret_type;
Ast_413.Outcometree.oext_private = oext_private }
->
{
Ast_414.Outcometree.oext_name = oext_name;
Ast_414.Outcometree.oext_type_name = oext_type_name;
Ast_414.Outcometree.oext_type_params =
(List.map (fun x -> x) oext_type_params);
Ast_414.Outcometree.oext_args = (List.map copy_out_type oext_args);
Ast_414.Outcometree.oext_ret_type =
(Option.map copy_out_type oext_ret_type);
Ast_414.Outcometree.oext_private = (copy_private_flag oext_private)
}
and copy_private_flag :
Ast_413.Asttypes.private_flag -> Ast_414.Asttypes.private_flag =
function
| Ast_413.Asttypes.Private -> Ast_414.Asttypes.Private
| Ast_413.Asttypes.Public -> Ast_414.Asttypes.Public
and copy_out_rec_status :
Ast_413.Outcometree.out_rec_status -> Ast_414.Outcometree.out_rec_status =
function
| Ast_413.Outcometree.Orec_not -> Ast_414.Outcometree.Orec_not
| Ast_413.Outcometree.Orec_first -> Ast_414.Outcometree.Orec_first
| Ast_413.Outcometree.Orec_next -> Ast_414.Outcometree.Orec_next
and copy_out_class_type :
Ast_413.Outcometree.out_class_type -> Ast_414.Outcometree.out_class_type =
function
| Ast_413.Outcometree.Octy_constr (x0, x1) ->
Ast_414.Outcometree.Octy_constr
((copy_out_ident x0), (List.map copy_out_type x1))
| Ast_413.Outcometree.Octy_arrow (x0, x1, x2) ->
Ast_414.Outcometree.Octy_arrow
(x0, (copy_out_type x1), (copy_out_class_type x2))
| Ast_413.Outcometree.Octy_signature (x0, x1) ->
Ast_414.Outcometree.Octy_signature
((Option.map copy_out_type x0),
(List.map copy_out_class_sig_item x1))
and copy_out_class_sig_item :
Ast_413.Outcometree.out_class_sig_item ->
Ast_414.Outcometree.out_class_sig_item
=
function
| Ast_413.Outcometree.Ocsg_constraint (x0, x1) ->
Ast_414.Outcometree.Ocsg_constraint
((copy_out_type x0), (copy_out_type x1))
| Ast_413.Outcometree.Ocsg_method (x0, x1, x2, x3) ->
Ast_414.Outcometree.Ocsg_method (x0, x1, x2, (copy_out_type x3))
| Ast_413.Outcometree.Ocsg_value (x0, x1, x2, x3) ->
Ast_414.Outcometree.Ocsg_value (x0, x1, x2, (copy_out_type x3))
and copy_out_type_param :
Ast_413.Outcometree.out_type_param -> Ast_414.Outcometree.out_type_param =
fun x ->
let (x0, x1) = x in
(x0, (let (x0, x1) = x1 in ((copy_variance x0), (copy_injectivity x1))))
and copy_injectivity :
Ast_413.Asttypes.injectivity -> Ast_414.Asttypes.injectivity =
function
| Ast_413.Asttypes.Injective -> Ast_414.Asttypes.Injective
| Ast_413.Asttypes.NoInjectivity -> Ast_414.Asttypes.NoInjectivity
and copy_variance : Ast_413.Asttypes.variance -> Ast_414.Asttypes.variance =
function
| Ast_413.Asttypes.Covariant -> Ast_414.Asttypes.Covariant
| Ast_413.Asttypes.Contravariant -> Ast_414.Asttypes.Contravariant
| Ast_413.Asttypes.NoVariance -> Ast_414.Asttypes.NoVariance
and copy_out_type :
Ast_413.Outcometree.out_type -> Ast_414.Outcometree.out_type =
function
| Ast_413.Outcometree.Otyp_abstract -> Ast_414.Outcometree.Otyp_abstract
| Ast_413.Outcometree.Otyp_open -> Ast_414.Outcometree.Otyp_open
| Ast_413.Outcometree.Otyp_alias (x0, x1) ->
Ast_414.Outcometree.Otyp_alias ((copy_out_type x0), x1)
| Ast_413.Outcometree.Otyp_arrow (x0, x1, x2) ->
Ast_414.Outcometree.Otyp_arrow
(x0, (copy_out_type x1), (copy_out_type x2))
| Ast_413.Outcometree.Otyp_class (x0, x1, x2) ->
Ast_414.Outcometree.Otyp_class
(x0, (copy_out_ident x1), (List.map copy_out_type x2))
| Ast_413.Outcometree.Otyp_constr (x0, x1) ->
Ast_414.Outcometree.Otyp_constr
((copy_out_ident x0), (List.map copy_out_type x1))
| Ast_413.Outcometree.Otyp_manifest (x0, x1) ->
Ast_414.Outcometree.Otyp_manifest
((copy_out_type x0), (copy_out_type x1))
| Ast_413.Outcometree.Otyp_object (x0, x1) ->
Ast_414.Outcometree.Otyp_object
((List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1))) x0),
(Option.map (fun x -> x) x1))
| Ast_413.Outcometree.Otyp_record x0 ->
Ast_414.Outcometree.Otyp_record
(List.map
(fun x -> let (x0, x1, x2) = x in (x0, x1, (copy_out_type x2))) x0)
| Ast_413.Outcometree.Otyp_stuff x0 -> Ast_414.Outcometree.Otyp_stuff x0
| Ast_413.Outcometree.Otyp_sum x0 ->
Ast_414.Outcometree.Otyp_sum
(List.map
(fun x ->
let (x0, x1, x2) = x in
let x1 = (List.map copy_out_type x1) in
let x2 = (Option.map copy_out_type x2) in
Ast_414.Outcometree.{ ocstr_name = x0; ocstr_args = x1; ocstr_return_type = x2 })
x0)
| Ast_413.Outcometree.Otyp_tuple x0 ->
Ast_414.Outcometree.Otyp_tuple (List.map copy_out_type x0)
| Ast_413.Outcometree.Otyp_var (x0, x1) ->
Ast_414.Outcometree.Otyp_var (x0, x1)
| Ast_413.Outcometree.Otyp_variant (x0, x1, x2, x3) ->
Ast_414.Outcometree.Otyp_variant
(x0, (copy_out_variant x1), x2,
(Option.map (fun x -> List.map (fun x -> x) x) x3))
| Ast_413.Outcometree.Otyp_poly (x0, x1) ->
Ast_414.Outcometree.Otyp_poly
((List.map (fun x -> x) x0), (copy_out_type x1))
| Ast_413.Outcometree.Otyp_module (x0, x1) ->
Ast_414.Outcometree.Otyp_module
((copy_out_ident x0),
(List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1)))
x1))
| Ast_413.Outcometree.Otyp_attribute (x0, x1) ->
Ast_414.Outcometree.Otyp_attribute
((copy_out_type x0), (copy_out_attribute x1))
and copy_out_attribute :
Ast_413.Outcometree.out_attribute -> Ast_414.Outcometree.out_attribute =
fun { Ast_413.Outcometree.oattr_name = oattr_name } ->
{ Ast_414.Outcometree.oattr_name = oattr_name }
and copy_out_variant :
Ast_413.Outcometree.out_variant -> Ast_414.Outcometree.out_variant =
function
| Ast_413.Outcometree.Ovar_fields x0 ->
Ast_414.Outcometree.Ovar_fields
(List.map
(fun x ->
let (x0, x1, x2) = x in (x0, x1, (List.map copy_out_type x2)))
x0)
| Ast_413.Outcometree.Ovar_typ x0 ->
Ast_414.Outcometree.Ovar_typ (copy_out_type x0)
and copy_out_value :
Ast_413.Outcometree.out_value -> Ast_414.Outcometree.out_value =
function
| Ast_413.Outcometree.Oval_array x0 ->
Ast_414.Outcometree.Oval_array (List.map copy_out_value x0)
| Ast_413.Outcometree.Oval_char x0 -> Ast_414.Outcometree.Oval_char x0
| Ast_413.Outcometree.Oval_constr (x0, x1) ->
Ast_414.Outcometree.Oval_constr
((copy_out_ident x0), (List.map copy_out_value x1))
| Ast_413.Outcometree.Oval_ellipsis -> Ast_414.Outcometree.Oval_ellipsis
| Ast_413.Outcometree.Oval_float x0 -> Ast_414.Outcometree.Oval_float x0
| Ast_413.Outcometree.Oval_int x0 -> Ast_414.Outcometree.Oval_int x0
| Ast_413.Outcometree.Oval_int32 x0 -> Ast_414.Outcometree.Oval_int32 x0
| Ast_413.Outcometree.Oval_int64 x0 -> Ast_414.Outcometree.Oval_int64 x0
| Ast_413.Outcometree.Oval_nativeint x0 ->
Ast_414.Outcometree.Oval_nativeint x0
| Ast_413.Outcometree.Oval_list x0 ->
Ast_414.Outcometree.Oval_list (List.map copy_out_value x0)
| Ast_413.Outcometree.Oval_printer x0 ->
Ast_414.Outcometree.Oval_printer x0
| Ast_413.Outcometree.Oval_record x0 ->
Ast_414.Outcometree.Oval_record
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_ident x0), (copy_out_value x1)))
x0)
| Ast_413.Outcometree.Oval_string (x0, x1, x2) ->
Ast_414.Outcometree.Oval_string (x0, x1, (copy_out_string x2))
| Ast_413.Outcometree.Oval_stuff x0 -> Ast_414.Outcometree.Oval_stuff x0
| Ast_413.Outcometree.Oval_tuple x0 ->
Ast_414.Outcometree.Oval_tuple (List.map copy_out_value x0)
| Ast_413.Outcometree.Oval_variant (x0, x1) ->
Ast_414.Outcometree.Oval_variant (x0, (Option.map copy_out_value x1))
and copy_out_string :
Ast_413.Outcometree.out_string -> Ast_414.Outcometree.out_string =
function
| Ast_413.Outcometree.Ostr_string -> Ast_414.Outcometree.Ostr_string
| Ast_413.Outcometree.Ostr_bytes -> Ast_414.Outcometree.Ostr_bytes
and copy_out_ident :
Ast_413.Outcometree.out_ident -> Ast_414.Outcometree.out_ident =
function
| Ast_413.Outcometree.Oide_apply (x0, x1) ->
Ast_414.Outcometree.Oide_apply
((copy_out_ident x0), (copy_out_ident x1))
| Ast_413.Outcometree.Oide_dot (x0, x1) ->
Ast_414.Outcometree.Oide_dot ((copy_out_ident x0), x1)
| Ast_413.Outcometree.Oide_ident x0 ->
Ast_414.Outcometree.Oide_ident (copy_out_name x0)
and copy_out_name :
Ast_413.Outcometree.out_name -> Ast_414.Outcometree.out_name =
fun { Ast_413.Outcometree.printed_name = printed_name } ->
{ Ast_414.Outcometree.printed_name = printed_name }
================================================
FILE: src/vendored-omp/src/migrate_parsetree_414_413.ml
================================================
(**************************************************************************)
(* *)
(* OCaml Migrate Parsetree *)
(* *)
(* Frédéric Bour *)
(* *)
(* Copyright 2017 Institut National de Recherche en Informatique et *)
(* en Automatique (INRIA). *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
include Migrate_parsetree_414_413_migrate
================================================
FILE: src/vendored-omp/src/migrate_parsetree_414_413_migrate.ml
================================================
open Stdlib0
module From = Ast_414
module To = Ast_413
let rec copy_out_type_extension :
Ast_414.Outcometree.out_type_extension ->
Ast_413.Outcometree.out_type_extension
=
fun
{ Ast_414.Outcometree.otyext_name = otyext_name;
Ast_414.Outcometree.otyext_params = otyext_params;
Ast_414.Outcometree.otyext_constructors = otyext_constructors;
Ast_414.Outcometree.otyext_private = otyext_private }
->
{
Ast_413.Outcometree.otyext_name = otyext_name;
Ast_413.Outcometree.otyext_params =
(List.map (fun x -> x) otyext_params);
Ast_413.Outcometree.otyext_constructors =
(List.map
(fun x ->
let { Ast_414.Outcometree.ocstr_name = x0; ocstr_args = x1; ocstr_return_type = x2 } = x in
(x0, (List.map copy_out_type x1),
(Option.map copy_out_type x2))) otyext_constructors);
Ast_413.Outcometree.otyext_private = (copy_private_flag otyext_private)
}
and copy_out_phrase :
Ast_414.Outcometree.out_phrase -> Ast_413.Outcometree.out_phrase =
function
| Ast_414.Outcometree.Ophr_eval (x0, x1) ->
Ast_413.Outcometree.Ophr_eval ((copy_out_value x0), (copy_out_type x1))
| Ast_414.Outcometree.Ophr_signature x0 ->
Ast_413.Outcometree.Ophr_signature
(List.map
(fun x ->
let (x0, x1) = x in
((copy_out_sig_item x0), (Option.map copy_out_value x1))) x0)
| Ast_414.Outcometree.Ophr_exception x0 ->
Ast_413.Outcometree.Ophr_exception
(let (x0, x1) = x0 in (x0, (copy_out_value x1)))
and copy_out_sig_item :
Ast_414.Outcometree.out_sig_item -> Ast_413.Outcometree.out_sig_item =
function
| Ast_414.Outcometree.Osig_class (x0, x1, x2, x3, x4) ->
Ast_413.Outcometree.Osig_class
(x0, x1, (List.map copy_out_type_param x2), (copy_out_class_type x3),
(copy_out_rec_status x4))
| Ast_414.Outcometree.Osig_class_type (x0, x1, x2, x3, x4) ->
Ast_413.Outcometree.Osig_class_type
(x0, x1, (List.map copy_out_type_param x2), (copy_out_class_type x3),
(copy_out_rec_status x4))
| Ast_414.Outcometree.Osig_typext (x0, x1) ->
Ast_413.Outcometree.Osig_typext
((copy_out_extension_constructor x0), (copy_out_ext_status x1))
| Ast_414.Outcometree.Osig_modtype (x0, x1) ->
Ast_413.Outcometree.Osig_modtype (x0, (copy_out_module_type x1))
| Ast_414.Outcometree.Osig_module (x0, x1, x2) ->
Ast_413.Outcometree.Osig_module
(x0, (copy_out_module_type x1), (copy_out_rec_status x2))
| Ast_414.Outcometree.Osig_type (x0, x1) ->
Ast_413.Outcometree.Osig_type
((copy_out_type_decl x0), (copy_out_rec_status x1))
| Ast_414.Outcometree.Osig_value x0 ->
Ast_413.Outcometree.Osig_value (copy_out_val_decl x0)
| Ast_414.Outcometree.Osig_ellipsis -> Ast_413.Outcometree.Osig_ellipsis
and copy_out_val_decl :
Ast_414.Outcometree.out_val_decl -> Ast_413.Outcometree.out_val_decl =
fun
{ Ast_414.Outcometree.oval_name = oval_name;
Ast_414.Outcometree.oval_type = oval_type;
Ast_414.Outcometree.oval_prims = oval_prims;
Ast_414.Outcometree.oval_attributes = oval_attributes }
->
{
Ast_413.Outcometree.oval_name = oval_name;
Ast_413.Outcometree.oval_type = (copy_out_type oval_type);
Ast_413.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims);
Ast_413.Outcometree.oval_attributes =
(List.map copy_out_attribute oval_attributes)
}
and copy_out_type_decl :
Ast_414.Outcometree.out_type_decl -> Ast_413.Outcometree.out_type_decl =
fun
{ Ast_414.Outcometree.otype_name = otype_name;
Ast_414.Outcometree.otype_params = otype_params;
Ast_414.Outcometree.otype_type = otype_type;
Ast_414.Outcometree.otype_private = otype_private;
Ast_414.Outcometree.otype_immediate = otype_immediate;
Ast_414.Outcometree.otype_unboxed = otype_unboxed;
Ast_414.Outcometree.otype_cstrs = otype_cstrs }
->
{
Ast_413.Outcometree.otype_name = otype_name;
Ast_413.Outcometree.otype_params =
(List.map copy_out_type_param otype_params);
Ast_413.Outcometree.otype_type = (copy_out_type otype_type);
Ast_413.Outcometree.otype_private = (copy_private_flag otype_private);
Ast_413.Outcometree.otype_immediate =
(copy_Type_immediacy_t otype_immediate);
Ast_413.Outcometree.otype_unboxed = otype_unboxed;
Ast_413.Outcometree.otype_cstrs =
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_type x0), (copy_out_type x1)))
otype_cstrs)
}
and copy_Type_immediacy_t :
Ast_414.Type_immediacy.t -> Ast_413.Type_immediacy.t =
function
| Ast_414.Type_immediacy.Unknown -> Ast_413.Type_immediacy.Unknown
| Ast_414.Type_immediacy.Always -> Ast_413.Type_immediacy.Always
| Ast_414.Type_immediacy.Always_on_64bits ->
Ast_413.Type_immediacy.Always_on_64bits
and copy_out_module_type :
Ast_414.Outcometree.out_module_type -> Ast_413.Outcometree.out_module_type
=
function
| Ast_414.Outcometree.Omty_abstract -> Ast_413.Outcometree.Omty_abstract
| Ast_414.Outcometree.Omty_functor (x0, x1) ->
Ast_413.Outcometree.Omty_functor
((Option.map
(fun x ->
let (x0, x1) = x in
((Option.map (fun x -> x) x0), (copy_out_module_type x1))) x0),
(copy_out_module_type x1))
| Ast_414.Outcometree.Omty_ident x0 ->
Ast_413.Outcometree.Omty_ident (copy_out_ident x0)
| Ast_414.Outcometree.Omty_signature x0 ->
Ast_413.Outcometree.Omty_signature (List.map copy_out_sig_item x0)
| Ast_414.Outcometree.Omty_alias x0 ->
Ast_413.Outcometree.Omty_alias (copy_out_ident x0)
and copy_out_ext_status :
Ast_414.Outcometree.out_ext_status -> Ast_413.Outcometree.out_ext_status =
function
| Ast_414.Outcometree.Oext_first -> Ast_413.Outcometree.Oext_first
| Ast_414.Outcometree.Oext_next -> Ast_413.Outcometree.Oext_next
| Ast_414.Outcometree.Oext_exception -> Ast_413.Outcometree.Oext_exception
and copy_out_extension_constructor :
Ast_414.Outcometree.out_extension_constructor ->
Ast_413.Outcometree.out_extension_constructor
=
fun
{ Ast_414.Outcometree.oext_name = oext_name;
Ast_414.Outcometree.oext_type_name = oext_type_name;
Ast_414.Outcometree.oext_type_params = oext_type_params;
Ast_414.Outcometree.oext_args = oext_args;
Ast_414.Outcometree.oext_ret_type = oext_ret_type;
Ast_414.Outcometree.oext_private = oext_private }
->
{
Ast_413.Outcometree.oext_name = oext_name;
Ast_413.Outcometree.oext_type_name = oext_type_name;
Ast_413.Outcometree.oext_type_params =
(List.map (fun x -> x) oext_type_params);
Ast_413.Outcometree.oext_args = (List.map copy_out_type oext_args);
Ast_413.Outcometree.oext_ret_type =
(Option.map copy_out_type oext_ret_type);
Ast_413.Outcometree.oext_private = (copy_private_flag oext_private)
}
and copy_private_flag :
Ast_414.Asttypes.private_flag -> Ast_413.Asttypes.private_flag =
function
| Ast_414.Asttypes.Private -> Ast_413.Asttypes.Private
| Ast_414.Asttypes.Public -> Ast_413.Asttypes.Public
and copy_out_rec_status :
Ast_414.Outcometree.out_rec_status -> Ast_413.Outcometree.out_rec_status =
function
| Ast_414.Outcometree.Orec_not -> Ast_413.Outcometree.Orec_not
| Ast_414.Outcometree.Orec_first -> Ast_413.Outcometree.Orec_first
| Ast_414.Outcometree.Orec_next -> Ast_413.Outcometree.Orec_next
and copy_out_class_type :
Ast_414.Outcometree.out_class_type -> Ast_413.Outcometree.out_class_type =
function
| Ast_414.Outcometree.Octy_constr (x0, x1) ->
Ast_413.Outcometree.Octy_constr
((copy_out_ident x0), (List.map copy_out_type x1))
| Ast_414.Outcometree.Octy_arrow (x0, x1, x2) ->
Ast_413.Outcometree.Octy_arrow
(x0, (copy_out_type x1), (copy_out_class_type x2))
| Ast_414.Outcometree.Octy_signature (x0, x1) ->
Ast_413.Outcometree.Octy_signature
((Option.map copy_out_type x0),
(List.map copy_out_class_sig_item x1))
and copy_out_class_sig_item :
Ast_414.Outcometree.out_class_sig_item ->
Ast_413.Outcometree.out_class_sig_item
=
function
| Ast_414.Outcometree.Ocsg_constraint (x0, x1) ->
Ast_413.Outcometree.Ocsg_constraint
((copy_out_type x0), (copy_out_type x1))
| Ast_414.Outcometree.Ocsg_method (x0, x1, x2, x3) ->
Ast_413.Outcometree.Ocsg_method (x0, x1, x2, (copy_out_type x3))
| Ast_414.Outcometree.Ocsg_value (x0, x1, x2, x3) ->
Ast_413.Outcometree.Ocsg_value (x0, x1, x2, (copy_out_type x3))
and copy_out_type_param :
Ast_414.Outcometree.out_type_param -> Ast_413.Outcometree.out_type_param =
fun x ->
let (x0, x1) = x in
(x0, (let (x0, x1) = x1 in ((copy_variance x0), (copy_injectivity x1))))
and copy_injectivity :
Ast_414.Asttypes.injectivity -> Ast_413.Asttypes.injectivity =
function
| Ast_414.Asttypes.Injective -> Ast_413.Asttypes.Injective
| Ast_414.Asttypes.NoInjectivity -> Ast_413.Asttypes.NoInjectivity
and copy_variance : Ast_414.Asttypes.variance -> Ast_413.Asttypes.variance =
function
| Ast_414.Asttypes.Covariant -> Ast_413.Asttypes.Covariant
| Ast_414.Asttypes.Contravariant -> Ast_413.Asttypes.Contravariant
| Ast_414.Asttypes.NoVariance -> Ast_413.Asttypes.NoVariance
and copy_out_type :
Ast_414.Outcometree.out_type -> Ast_413.Outcometree.out_type =
function
| Ast_414.Outcometree.Otyp_abstract -> Ast_413.Outcometree.Otyp_abstract
| Ast_414.Outcometree.Otyp_open -> Ast_413.Outcometree.Otyp_open
| Ast_414.Outcometree.Otyp_alias (x0, x1) ->
Ast_413.Outcometree.Otyp_alias ((copy_out_type x0), x1)
| Ast_414.Outcometree.Otyp_arrow (x0, x1, x2) ->
Ast_413.Outcometree.Otyp_arrow
(x0, (copy_out_type x1), (copy_out_type x2))
| Ast_414.Outcometree.Otyp_class (x0, x1, x2) ->
Ast_413.Outcometree.Otyp_class
(x0, (copy_out_ident x1), (List.map copy_out_type x2))
| Ast_414.Outcometree.Otyp_constr (x0, x1) ->
Ast_413.Outcometree.Otyp_constr
((copy_out_ident x0), (List.map copy_out_type x1))
| Ast_414.Outcometree.Otyp_manifest (x0, x1) ->
Ast_413.Outcometree.Otyp_manifest
((copy_out_type x0), (copy_out_type x1))
| Ast_414.Outcometree.Otyp_object (x0, x1) ->
Ast_413.Outcometree.Otyp_object
((List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1))) x0),
(Option.map (fun x -> x) x1))
| Ast_414.Outcometree.Otyp_record x0 ->
Ast_413.Outcometree.Otyp_record
(List.map
(fun x -> let (x0, x1, x2) = x in (x0, x1, (copy_out_type x2))) x0)
| Ast_414.Outcometree.Otyp_stuff x0 -> Ast_413.Outcometree.Otyp_stuff x0
| Ast_414.Outcometree.Otyp_sum x0 ->
Ast_413.Outcometree.Otyp_sum
(List.map
(fun x ->
let { Ast_414.Outcometree.ocstr_name = x0; ocstr_args = x1; ocstr_return_type = x2 } = x in
(x0, (List.map copy_out_type x1),
(Option.map copy_out_type x2))) x0)
| Ast_414.Outcometree.Otyp_tuple x0 ->
Ast_413.Outcometree.Otyp_tuple (List.map copy_out_type x0)
| Ast_414.Outcometree.Otyp_var (x0, x1) ->
Ast_413.Outcometree.Otyp_var (x0, x1)
| Ast_414.Outcometree.Otyp_variant (x0, x1, x2, x3) ->
Ast_413.Outcometree.Otyp_variant
(x0, (copy_out_variant x1), x2,
(Option.map (fun x -> List.map (fun x -> x) x) x3))
| Ast_414.Outcometree.Otyp_poly (x0, x1) ->
Ast_413.Outcometree.Otyp_poly
((List.map (fun x -> x) x0), (copy_out_type x1))
| Ast_414.Outcometree.Otyp_module (x0, x1) ->
Ast_413.Outcometree.Otyp_module
((copy_out_ident x0),
(List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1)))
x1))
| Ast_414.Outcometree.Otyp_attribute (x0, x1) ->
Ast_413.Outcometree.Otyp_attribute
((copy_out_type x0), (copy_out_attribute x1))
and copy_out_attribute :
Ast_414.Outcometree.out_attribute -> Ast_413.Outcometree.out_attribute =
fun { Ast_414.Outcometree.oattr_name = oattr_name } ->
{ Ast_413.Outcometree.oattr_name = oattr_name }
and copy_out_variant :
Ast_414.Outcometree.out_variant -> Ast_413.Outcometree.out_variant =
function
| Ast_414.Outcometree.Ovar_fields x0 ->
Ast_413.Outcometree.Ovar_fields
(List.map
(fun x ->
let (x0, x1, x2) = x in (x0, x1, (List.map copy_out_type x2)))
x0)
| Ast_414.Outcometree.Ovar_typ x0 ->
Ast_413.Outcometree.Ovar_typ (copy_out_type x0)
and copy_out_value :
Ast_414.Outcometree.out_value -> Ast_413.Outcometree.out_value =
function
| Ast_414.Outcometree.Oval_array x0 ->
Ast_413.Outcometree.Oval_array (List.map copy_out_value x0)
| Ast_414.Outcometree.Oval_char x0 -> Ast_413.Outcometree.Oval_char x0
| Ast_414.Outcometree.Oval_constr (x0, x1) ->
Ast_413.Outcometree.Oval_constr
((copy_out_ident x0), (List.map copy_out_value x1))
| Ast_414.Outcometree.Oval_ellipsis -> Ast_413.Outcometree.Oval_ellipsis
| Ast_414.Outcometree.Oval_float x0 -> Ast_413.Outcometree.Oval_float x0
| Ast_414.Outcometree.Oval_int x0 -> Ast_413.Outcometree.Oval_int x0
| Ast_414.Outcometree.Oval_int32 x0 -> Ast_413.Outcometree.Oval_int32 x0
| Ast_414.Outcometree.Oval_int64 x0 -> Ast_413.Outcometree.Oval_int64 x0
| Ast_414.Outcometree.Oval_nativeint x0 ->
Ast_413.Outcometree.Oval_nativeint x0
| Ast_414.Outcometree.Oval_list x0 ->
Ast_413.Outcometree.Oval_list (List.map copy_out_value x0)
| Ast_414.Outcometree.Oval_printer x0 ->
Ast_413.Outcometree.Oval_printer x0
| Ast_414.Outcometree.Oval_record x0 ->
Ast_413.Outcometree.Oval_record
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_ident x0), (copy_out_value x1)))
x0)
| Ast_414.Outcometree.Oval_string (x0, x1, x2) ->
Ast_413.Outcometree.Oval_string (x0, x1, (copy_out_string x2))
| Ast_414.Outcometree.Oval_stuff x0 -> Ast_413.Outcometree.Oval_stuff x0
| Ast_414.Outcometree.Oval_tuple x0 ->
Ast_413.Outcometree.Oval_tuple (List.map copy_out_value x0)
| Ast_414.Outcometree.Oval_variant (x0, x1) ->
Ast_413.Outcometree.Oval_variant (x0, (Option.map copy_out_value x1))
and copy_out_string :
Ast_414.Outcometree.out_string -> Ast_413.Outcometree.out_string =
function
| Ast_414.Outcometree.Ostr_string -> Ast_413.Outcometree.Ostr_string
| Ast_414.Outcometree.Ostr_bytes -> Ast_413.Outcometree.Ostr_bytes
and copy_out_ident :
Ast_414.Outcometree.out_ident -> Ast_413.Outcometree.out_ident =
function
| Ast_414.Outcometree.Oide_apply (x0, x1) ->
Ast_413.Outcometree.Oide_apply
((copy_out_ident x0), (copy_out_ident x1))
| Ast_414.Outcometree.Oide_dot (x0, x1) ->
Ast_413.Outcometree.Oide_dot ((copy_out_ident x0), x1)
| Ast_414.Outcometree.Oide_ident x0 ->
Ast_413.Outcometree.Oide_ident (copy_out_name x0)
and copy_out_name :
Ast_414.Outcometree.out_name -> Ast_413.Outcometree.out_name =
fun { Ast_414.Outcometree.printed_name = printed_name } ->
{ Ast_413.Outcometree.printed_name = printed_name }
================================================
FILE: src/vendored-omp/src/migrate_parsetree_414_500.ml
================================================
(**************************************************************************)
(* *)
(* OCaml Migrate Parsetree *)
(* *)
(* Frédéric Bour *)
(* *)
(* Copyright 2017 Institut National de Recherche en Informatique et *)
(* en Automatique (INRIA). *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
include Migrate_parsetree_414_500_migrate
================================================
FILE: src/vendored-omp/src/migrate_parsetree_414_500_migrate.ml
================================================
open Stdlib0
module From = Ast_414
module To = Ast_500
let rec copy_out_type_extension :
Ast_414.Outcometree.out_type_extension ->
Ast_500.Outcometree.out_type_extension
=
fun
{ Ast_414.Outcometree.otyext_name = otyext_name;
Ast_414.Outcometree.otyext_params = otyext_params;
Ast_414.Outcometree.otyext_constructors = otyext_constructors;
Ast_414.Outcometree.otyext_private = otyext_private }
->
{
Ast_500.Outcometree.otyext_name = otyext_name;
Ast_500.Outcometree.otyext_params =
(List.map (fun x -> x) otyext_params);
Ast_500.Outcometree.otyext_constructors =
(List.map copy_out_constructor otyext_constructors);
Ast_500.Outcometree.otyext_private = (copy_private_flag otyext_private)
}
and copy_out_phrase :
Ast_414.Outcometree.out_phrase -> Ast_500.Outcometree.out_phrase =
function
| Ast_414.Outcometree.Ophr_eval (x0, x1) ->
Ast_500.Outcometree.Ophr_eval ((copy_out_value x0), (copy_out_type x1))
| Ast_414.Outcometree.Ophr_signature x0 ->
Ast_500.Outcometree.Ophr_signature
(List.map
(fun x ->
let (x0, x1) = x in
((copy_out_sig_item x0), (Option.map copy_out_value x1))) x0)
| Ast_414.Outcometree.Ophr_exception x0 ->
Ast_500.Outcometree.Ophr_exception
(let (x0, x1) = x0 in (x0, (copy_out_value x1)))
and copy_out_sig_item :
Ast_414.Outcometree.out_sig_item -> Ast_500.Outcometree.out_sig_item =
function
| Ast_414.Outcometree.Osig_class (x0, x1, x2, x3, x4) ->
Ast_500.Outcometree.Osig_class
(x0, x1, (List.map copy_out_type_param x2), (copy_out_class_type x3),
(copy_out_rec_status x4))
| Ast_414.Outcometree.Osig_class_type (x0, x1, x2, x3, x4) ->
Ast_500.Outcometree.Osig_class_type
(x0, x1, (List.map copy_out_type_param x2), (copy_out_class_type x3),
(copy_out_rec_status x4))
| Ast_414.Outcometree.Osig_typext (x0, x1) ->
Ast_500.Outcometree.Osig_typext
((copy_out_extension_constructor x0), (copy_out_ext_status x1))
| Ast_414.Outcometree.Osig_modtype (x0, x1) ->
Ast_500.Outcometree.Osig_modtype (x0, (copy_out_module_type x1))
| Ast_414.Outcometree.Osig_module (x0, x1, x2) ->
Ast_500.Outcometree.Osig_module
(x0, (copy_out_module_type x1), (copy_out_rec_status x2))
| Ast_414.Outcometree.Osig_type (x0, x1) ->
Ast_500.Outcometree.Osig_type
((copy_out_type_decl x0), (copy_out_rec_status x1))
| Ast_414.Outcometree.Osig_value x0 ->
Ast_500.Outcometree.Osig_value (copy_out_val_decl x0)
| Ast_414.Outcometree.Osig_ellipsis -> Ast_500.Outcometree.Osig_ellipsis
and copy_out_val_decl :
Ast_414.Outcometree.out_val_decl -> Ast_500.Outcometree.out_val_decl =
fun
{ Ast_414.Outcometree.oval_name = oval_name;
Ast_414.Outcometree.oval_type = oval_type;
Ast_414.Outcometree.oval_prims = oval_prims;
Ast_414.Outcometree.oval_attributes = oval_attributes }
->
{
Ast_500.Outcometree.oval_name = oval_name;
Ast_500.Outcometree.oval_type = (copy_out_type oval_type);
Ast_500.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims);
Ast_500.Outcometree.oval_attributes =
(List.map copy_out_attribute oval_attributes)
}
and copy_out_type_decl :
Ast_414.Outcometree.out_type_decl -> Ast_500.Outcometree.out_type_decl =
fun
{ Ast_414.Outcometree.otype_name = otype_name;
Ast_414.Outcometree.otype_params = otype_params;
Ast_414.Outcometree.otype_type = otype_type;
Ast_414.Outcometree.otype_private = otype_private;
Ast_414.Outcometree.otype_immediate = otype_immediate;
Ast_414.Outcometree.otype_unboxed = otype_unboxed;
Ast_414.Outcometree.otype_cstrs = otype_cstrs }
->
{
Ast_500.Outcometree.otype_name = otype_name;
Ast_500.Outcometree.otype_params =
(List.map copy_out_type_param otype_params);
Ast_500.Outcometree.otype_type = (copy_out_type otype_type);
Ast_500.Outcometree.otype_private = (copy_private_flag otype_private);
Ast_500.Outcometree.otype_immediate =
(copy_Type_immediacy_t otype_immediate);
Ast_500.Outcometree.otype_unboxed = otype_unboxed;
Ast_500.Outcometree.otype_cstrs =
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_type x0), (copy_out_type x1)))
otype_cstrs)
}
and copy_Type_immediacy_t :
Ast_414.Type_immediacy.t -> Ast_500.Type_immediacy.t =
function
| Ast_414.Type_immediacy.Unknown -> Ast_500.Type_immediacy.Unknown
| Ast_414.Type_immediacy.Always -> Ast_500.Type_immediacy.Always
| Ast_414.Type_immediacy.Always_on_64bits ->
Ast_500.Type_immediacy.Always_on_64bits
and copy_out_module_type :
Ast_414.Outcometree.out_module_type -> Ast_500.Outcometree.out_module_type
=
function
| Ast_414.Outcometree.Omty_abstract -> Ast_500.Outcometree.Omty_abstract
| Ast_414.Outcometree.Omty_functor (x0, x1) ->
Ast_500.Outcometree.Omty_functor
((Option.map
(fun x ->
let (x0, x1) = x in
((Option.map (fun x -> x) x0), (copy_out_module_type x1))) x0),
(copy_out_module_type x1))
| Ast_414.Outcometree.Omty_ident x0 ->
Ast_500.Outcometree.Omty_ident (copy_out_ident x0)
| Ast_414.Outcometree.Omty_signature x0 ->
Ast_500.Outcometree.Omty_signature (List.map copy_out_sig_item x0)
| Ast_414.Outcometree.Omty_alias x0 ->
Ast_500.Outcometree.Omty_alias (copy_out_ident x0)
and copy_out_ext_status :
Ast_414.Outcometree.out_ext_status -> Ast_500.Outcometree.out_ext_status =
function
| Ast_414.Outcometree.Oext_first -> Ast_500.Outcometree.Oext_first
| Ast_414.Outcometree.Oext_next -> Ast_500.Outcometree.Oext_next
| Ast_414.Outcometree.Oext_exception -> Ast_500.Outcometree.Oext_exception
and copy_out_extension_constructor :
Ast_414.Outcometree.out_extension_constructor ->
Ast_500.Outcometree.out_extension_constructor
=
fun
{ Ast_414.Outcometree.oext_name = oext_name;
Ast_414.Outcometree.oext_type_name = oext_type_name;
Ast_414.Outcometree.oext_type_params = oext_type_params;
Ast_414.Outcometree.oext_args = oext_args;
Ast_414.Outcometree.oext_ret_type = oext_ret_type;
Ast_414.Outcometree.oext_private = oext_private }
->
{
Ast_500.Outcometree.oext_name = oext_name;
Ast_500.Outcometree.oext_type_name = oext_type_name;
Ast_500.Outcometree.oext_type_params =
(List.map (fun x -> x) oext_type_params);
Ast_500.Outcometree.oext_args = (List.map copy_out_type oext_args);
Ast_500.Outcometree.oext_ret_type =
(Option.map copy_out_type oext_ret_type);
Ast_500.Outcometree.oext_private = (copy_private_flag oext_private)
}
and copy_private_flag :
Ast_414.Asttypes.private_flag -> Ast_500.Asttypes.private_flag =
function
| Ast_414.Asttypes.Private -> Ast_500.Asttypes.Private
| Ast_414.Asttypes.Public -> Ast_500.Asttypes.Public
and copy_out_rec_status :
Ast_414.Outcometree.out_rec_status -> Ast_500.Outcometree.out_rec_status =
function
| Ast_414.Outcometree.Orec_not -> Ast_500.Outcometree.Orec_not
| Ast_414.Outcometree.Orec_first -> Ast_500.Outcometree.Orec_first
| Ast_414.Outcometree.Orec_next -> Ast_500.Outcometree.Orec_next
and copy_out_class_type :
Ast_414.Outcometree.out_class_type -> Ast_500.Outcometree.out_class_type =
function
| Ast_414.Outcometree.Octy_constr (x0, x1) ->
Ast_500.Outcometree.Octy_constr
((copy_out_ident x0), (List.map copy_out_type x1))
| Ast_414.Outcometree.Octy_arrow (x0, x1, x2) ->
Ast_500.Outcometree.Octy_arrow
(x0, (copy_out_type x1), (copy_out_class_type x2))
| Ast_414.Outcometree.Octy_signature (x0, x1) ->
Ast_500.Outcometree.Octy_signature
((Option.map copy_out_type x0),
(List.map copy_out_class_sig_item x1))
and copy_out_class_sig_item :
Ast_414.Outcometree.out_class_sig_item ->
Ast_500.Outcometree.out_class_sig_item
=
function
| Ast_414.Outcometree.Ocsg_constraint (x0, x1) ->
Ast_500.Outcometree.Ocsg_constraint
((copy_out_type x0), (copy_out_type x1))
| Ast_414.Outcometree.Ocsg_method (x0, x1, x2, x3) ->
Ast_500.Outcometree.Ocsg_method (x0, x1, x2, (copy_out_type x3))
| Ast_414.Outcometree.Ocsg_value (x0, x1, x2, x3) ->
Ast_500.Outcometree.Ocsg_value (x0, x1, x2, (copy_out_type x3))
and copy_out_type_param :
Ast_414.Outcometree.out_type_param -> Ast_500.Outcometree.out_type_param =
fun x ->
let (x0, x1) = x in
(x0, (let (x0, x1) = x1 in ((copy_variance x0), (copy_injectivity x1))))
and copy_injectivity :
Ast_414.Asttypes.injectivity -> Ast_500.Asttypes.injectivity =
function
| Ast_414.Asttypes.Injective -> Ast_500.Asttypes.Injective
| Ast_414.Asttypes.NoInjectivity -> Ast_500.Asttypes.NoInjectivity
and copy_variance : Ast_414.Asttypes.variance -> Ast_500.Asttypes.variance =
function
| Ast_414.Asttypes.Covariant -> Ast_500.Asttypes.Covariant
| Ast_414.Asttypes.Contravariant -> Ast_500.Asttypes.Contravariant
| Ast_414.Asttypes.NoVariance -> Ast_500.Asttypes.NoVariance
and copy_out_type :
Ast_414.Outcometree.out_type -> Ast_500.Outcometree.out_type =
function
| Ast_414.Outcometree.Otyp_abstract -> Ast_500.Outcometree.Otyp_abstract
| Ast_414.Outcometree.Otyp_open -> Ast_500.Outcometree.Otyp_open
| Ast_414.Outcometree.Otyp_alias (x0, x1) ->
Ast_500.Outcometree.Otyp_alias ((copy_out_type x0), x1)
| Ast_414.Outcometree.Otyp_arrow (x0, x1, x2) ->
Ast_500.Outcometree.Otyp_arrow
(x0, (copy_out_type x1), (copy_out_type x2))
| Ast_414.Outcometree.Otyp_class (x0, x1, x2) ->
Ast_500.Outcometree.Otyp_class
(x0, (copy_out_ident x1), (List.map copy_out_type x2))
| Ast_414.Outcometree.Otyp_constr (x0, x1) ->
Ast_500.Outcometree.Otyp_constr
((copy_out_ident x0), (List.map copy_out_type x1))
| Ast_414.Outcometree.Otyp_manifest (x0, x1) ->
Ast_500.Outcometree.Otyp_manifest
((copy_out_type x0), (copy_out_type x1))
| Ast_414.Outcometree.Otyp_object (x0, x1) ->
Ast_500.Outcometree.Otyp_object
((List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1))) x0),
(Option.map (fun x -> x) x1))
| Ast_414.Outcometree.Otyp_record x0 ->
Ast_500.Outcometree.Otyp_record
(List.map
(fun x -> let (x0, x1, x2) = x in (x0, x1, (copy_out_type x2))) x0)
| Ast_414.Outcometree.Otyp_stuff x0 -> Ast_500.Outcometree.Otyp_stuff x0
| Ast_414.Outcometree.Otyp_sum x0 ->
Ast_500.Outcometree.Otyp_sum (List.map copy_out_constructor x0)
| Ast_414.Outcometree.Otyp_tuple x0 ->
Ast_500.Outcometree.Otyp_tuple (List.map copy_out_type x0)
| Ast_414.Outcometree.Otyp_var (x0, x1) ->
Ast_500.Outcometree.Otyp_var (x0, x1)
| Ast_414.Outcometree.Otyp_variant (x0, x1, x2, x3) ->
Ast_500.Outcometree.Otyp_variant
(x0, (copy_out_variant x1), x2,
(Option.map (fun x -> List.map (fun x -> x) x) x3))
| Ast_414.Outcometree.Otyp_poly (x0, x1) ->
Ast_500.Outcometree.Otyp_poly
((List.map (fun x -> x) x0), (copy_out_type x1))
| Ast_414.Outcometree.Otyp_module (x0, x1) ->
Ast_500.Outcometree.Otyp_module
((copy_out_ident x0),
(List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1)))
x1))
| Ast_414.Outcometree.Otyp_attribute (x0, x1) ->
Ast_500.Outcometree.Otyp_attribute
((copy_out_type x0), (copy_out_attribute x1))
and copy_out_attribute :
Ast_414.Outcometree.out_attribute -> Ast_500.Outcometree.out_attribute =
fun { Ast_414.Outcometree.oattr_name = oattr_name } ->
{ Ast_500.Outcometree.oattr_name = oattr_name }
and copy_out_variant :
Ast_414.Outcometree.out_variant -> Ast_500.Outcometree.out_variant =
function
| Ast_414.Outcometree.Ovar_fields x0 ->
Ast_500.Outcometree.Ovar_fields
(List.map
(fun x ->
let (x0, x1, x2) = x in (x0, x1, (List.map copy_out_type x2)))
x0)
| Ast_414.Outcometree.Ovar_typ x0 ->
Ast_500.Outcometree.Ovar_typ (copy_out_type x0)
and copy_out_constructor :
Ast_414.Outcometree.out_constructor -> Ast_500.Outcometree.out_constructor
=
fun
{ Ast_414.Outcometree.ocstr_name = ocstr_name;
Ast_414.Outcometree.ocstr_args = ocstr_args;
Ast_414.Outcometree.ocstr_return_type = ocstr_return_type }
->
{
Ast_500.Outcometree.ocstr_name = ocstr_name;
Ast_500.Outcometree.ocstr_args = (List.map copy_out_type ocstr_args);
Ast_500.Outcometree.ocstr_return_type =
(Option.map copy_out_type ocstr_return_type)
}
and copy_out_value :
Ast_414.Outcometree.out_value -> Ast_500.Outcometree.out_value =
function
| Ast_414.Outcometree.Oval_array x0 ->
Ast_500.Outcometree.Oval_array (List.map copy_out_value x0)
| Ast_414.Outcometree.Oval_char x0 -> Ast_500.Outcometree.Oval_char x0
| Ast_414.Outcometree.Oval_constr (x0, x1) ->
Ast_500.Outcometree.Oval_constr
((copy_out_ident x0), (List.map copy_out_value x1))
| Ast_414.Outcometree.Oval_ellipsis -> Ast_500.Outcometree.Oval_ellipsis
| Ast_414.Outcometree.Oval_float x0 -> Ast_500.Outcometree.Oval_float x0
| Ast_414.Outcometree.Oval_int x0 -> Ast_500.Outcometree.Oval_int x0
| Ast_414.Outcometree.Oval_int32 x0 -> Ast_500.Outcometree.Oval_int32 x0
| Ast_414.Outcometree.Oval_int64 x0 -> Ast_500.Outcometree.Oval_int64 x0
| Ast_414.Outcometree.Oval_nativeint x0 ->
Ast_500.Outcometree.Oval_nativeint x0
| Ast_414.Outcometree.Oval_list x0 ->
Ast_500.Outcometree.Oval_list (List.map copy_out_value x0)
| Ast_414.Outcometree.Oval_printer x0 ->
Ast_500.Outcometree.Oval_printer x0
| Ast_414.Outcometree.Oval_record x0 ->
Ast_500.Outcometree.Oval_record
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_ident x0), (copy_out_value x1)))
x0)
| Ast_414.Outcometree.Oval_string (x0, x1, x2) ->
Ast_500.Outcometree.Oval_string (x0, x1, (copy_out_string x2))
| Ast_414.Outcometree.Oval_stuff x0 -> Ast_500.Outcometree.Oval_stuff x0
| Ast_414.Outcometree.Oval_tuple x0 ->
Ast_500.Outcometree.Oval_tuple (List.map copy_out_value x0)
| Ast_414.Outcometree.Oval_variant (x0, x1) ->
Ast_500.Outcometree.Oval_variant (x0, (Option.map copy_out_value x1))
and copy_out_string :
Ast_414.Outcometree.out_string -> Ast_500.Outcometree.out_string =
function
| Ast_414.Outcometree.Ostr_string -> Ast_500.Outcometree.Ostr_string
| Ast_414.Outcometree.Ostr_bytes -> Ast_500.Outcometree.Ostr_bytes
and copy_out_ident :
Ast_414.Outcometree.out_ident -> Ast_500.Outcometree.out_ident =
function
| Ast_414.Outcometree.Oide_apply (x0, x1) ->
Ast_500.Outcometree.Oide_apply
((copy_out_ident x0), (copy_out_ident x1))
| Ast_414.Outcometree.Oide_dot (x0, x1) ->
Ast_500.Outcometree.Oide_dot ((copy_out_ident x0), x1)
| Ast_414.Outcometree.Oide_ident x0 ->
Ast_500.Outcometree.Oide_ident (copy_out_name x0)
and copy_out_name :
Ast_414.Outcometree.out_name -> Ast_500.Outcometree.out_name =
fun { Ast_414.Outcometree.printed_name = printed_name } ->
{ Ast_500.Outcometree.printed_name = printed_name }
================================================
FILE: src/vendored-omp/src/migrate_parsetree_500_414.ml
================================================
(**************************************************************************)
(* *)
(* OCaml Migrate Parsetree *)
(* *)
(* Frédéric Bour *)
(* *)
(* Copyright 2017 Institut National de Recherche en Informatique et *)
(* en Automatique (INRIA). *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
include Migrate_parsetree_500_414_migrate
================================================
FILE: src/vendored-omp/src/migrate_parsetree_500_414_migrate.ml
================================================
open Stdlib0
module From = Ast_500
module To = Ast_414
let rec copy_out_type_extension :
Ast_500.Outcometree.out_type_extension ->
Ast_414.Outcometree.out_type_extension
=
fun
{ Ast_500.Outcometree.otyext_name = otyext_name;
Ast_500.Outcometree.otyext_params = otyext_params;
Ast_500.Outcometree.otyext_constructors = otyext_constructors;
Ast_500.Outcometree.otyext_private = otyext_private }
->
{
Ast_414.Outcometree.otyext_name = otyext_name;
Ast_414.Outcometree.otyext_params =
(List.map (fun x -> x) otyext_params);
Ast_414.Outcometree.otyext_constructors =
(List.map copy_out_constructor otyext_constructors);
Ast_414.Outcometree.otyext_private = (copy_private_flag otyext_private)
}
and copy_out_phrase :
Ast_500.Outcometree.out_phrase -> Ast_414.Outcometree.out_phrase =
function
| Ast_500.Outcometree.Ophr_eval (x0, x1) ->
Ast_414.Outcometree.Ophr_eval ((copy_out_value x0), (copy_out_type x1))
| Ast_500.Outcometree.Ophr_signature x0 ->
Ast_414.Outcometree.Ophr_signature
(List.map
(fun x ->
let (x0, x1) = x in
((copy_out_sig_item x0), (Option.map copy_out_value x1))) x0)
| Ast_500.Outcometree.Ophr_exception x0 ->
Ast_414.Outcometree.Ophr_exception
(let (x0, x1) = x0 in (x0, (copy_out_value x1)))
and copy_out_sig_item :
Ast_500.Outcometree.out_sig_item -> Ast_414.Outcometree.out_sig_item =
function
| Ast_500.Outcometree.Osig_class (x0, x1, x2, x3, x4) ->
Ast_414.Outcometree.Osig_class
(x0, x1, (List.map copy_out_type_param x2), (copy_out_class_type x3),
(copy_out_rec_status x4))
| Ast_500.Outcometree.Osig_class_type (x0, x1, x2, x3, x4) ->
Ast_414.Outcometree.Osig_class_type
(x0, x1, (List.map copy_out_type_param x2), (copy_out_class_type x3),
(copy_out_rec_status x4))
| Ast_500.Outcometree.Osig_typext (x0, x1) ->
Ast_414.Outcometree.Osig_typext
((copy_out_extension_constructor x0), (copy_out_ext_status x1))
| Ast_500.Outcometree.Osig_modtype (x0, x1) ->
Ast_414.Outcometree.Osig_modtype (x0, (copy_out_module_type x1))
| Ast_500.Outcometree.Osig_module (x0, x1, x2) ->
Ast_414.Outcometree.Osig_module
(x0, (copy_out_module_type x1), (copy_out_rec_status x2))
| Ast_500.Outcometree.Osig_type (x0, x1) ->
Ast_414.Outcometree.Osig_type
((copy_out_type_decl x0), (copy_out_rec_status x1))
| Ast_500.Outcometree.Osig_value x0 ->
Ast_414.Outcometree.Osig_value (copy_out_val_decl x0)
| Ast_500.Outcometree.Osig_ellipsis -> Ast_414.Outcometree.Osig_ellipsis
and copy_out_val_decl :
Ast_500.Outcometree.out_val_decl -> Ast_414.Outcometree.out_val_decl =
fun
{ Ast_500.Outcometree.oval_name = oval_name;
Ast_500.Outcometree.oval_type = oval_type;
Ast_500.Outcometree.oval_prims = oval_prims;
Ast_500.Outcometree.oval_attributes = oval_attributes }
->
{
Ast_414.Outcometree.oval_name = oval_name;
Ast_414.Outcometree.oval_type = (copy_out_type oval_type);
Ast_414.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims);
Ast_414.Outcometree.oval_attributes =
(List.map copy_out_attribute oval_attributes)
}
and copy_out_type_decl :
Ast_500.Outcometree.out_type_decl -> Ast_414.Outcometree.out_type_decl =
fun
{ Ast_500.Outcometree.otype_name = otype_name;
Ast_500.Outcometree.otype_params = otype_params;
Ast_500.Outcometree.otype_type = otype_type;
Ast_500.Outcometree.otype_private = otype_private;
Ast_500.Outcometree.otype_immediate = otype_immediate;
Ast_500.Outcometree.otype_unboxed = otype_unboxed;
Ast_500.Outcometree.otype_cstrs = otype_cstrs }
->
{
Ast_414.Outcometree.otype_name = otype_name;
Ast_414.Outcometree.otype_params =
(List.map copy_out_type_param otype_params);
Ast_414.Outcometree.otype_type = (copy_out_type otype_type);
Ast_414.Outcometree.otype_private = (copy_private_flag otype_private);
Ast_414.Outcometree.otype_immediate =
(copy_Type_immediacy_t otype_immediate);
Ast_414.Outcometree.otype_unboxed = otype_unboxed;
Ast_414.Outcometree.otype_cstrs =
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_type x0), (copy_out_type x1)))
otype_cstrs)
}
and copy_Type_immediacy_t :
Ast_500.Type_immediacy.t -> Ast_414.Type_immediacy.t =
function
| Ast_500.Type_immediacy.Unknown -> Ast_414.Type_immediacy.Unknown
| Ast_500.Type_immediacy.Always -> Ast_414.Type_immediacy.Always
| Ast_500.Type_immediacy.Always_on_64bits ->
Ast_414.Type_immediacy.Always_on_64bits
and copy_out_module_type :
Ast_500.Outcometree.out_module_type -> Ast_414.Outcometree.out_module_type
=
function
| Ast_500.Outcometree.Omty_abstract -> Ast_414.Outcometree.Omty_abstract
| Ast_500.Outcometree.Omty_functor (x0, x1) ->
Ast_414.Outcometree.Omty_functor
((Option.map
(fun x ->
let (x0, x1) = x in
((Option.map (fun x -> x) x0), (copy_out_module_type x1))) x0),
(copy_out_module_type x1))
| Ast_500.Outcometree.Omty_ident x0 ->
Ast_414.Outcometree.Omty_ident (copy_out_ident x0)
| Ast_500.Outcometree.Omty_signature x0 ->
Ast_414.Outcometree.Omty_signature (List.map copy_out_sig_item x0)
| Ast_500.Outcometree.Omty_alias x0 ->
Ast_414.Outcometree.Omty_alias (copy_out_ident x0)
and copy_out_ext_status :
Ast_500.Outcometree.out_ext_status -> Ast_414.Outcometree.out_ext_status =
function
| Ast_500.Outcometree.Oext_first -> Ast_414.Outcometree.Oext_first
| Ast_500.Outcometree.Oext_next -> Ast_414.Outcometree.Oext_next
| Ast_500.Outcometree.Oext_exception -> Ast_414.Outcometree.Oext_exception
and copy_out_extension_constructor :
Ast_500.Outcometree.out_extension_constructor ->
Ast_414.Outcometree.out_extension_constructor
=
fun
{ Ast_500.Outcometree.oext_name = oext_name;
Ast_500.Outcometree.oext_type_name = oext_type_name;
Ast_500.Outcometree.oext_type_params = oext_type_params;
Ast_500.Outcometree.oext_args = oext_args;
Ast_500.Outcometree.oext_ret_type = oext_ret_type;
Ast_500.Outcometree.oext_private = oext_private }
->
{
Ast_414.Outcometree.oext_name = oext_name;
Ast_414.Outcometree.oext_type_name = oext_type_name;
Ast_414.Outcometree.oext_type_params =
(List.map (fun x -> x) oext_type_params);
Ast_414.Outcometree.oext_args = (List.map copy_out_type oext_args);
Ast_414.Outcometree.oext_ret_type =
(Option.map copy_out_type oext_ret_type);
Ast_414.Outcometree.oext_private = (copy_private_flag oext_private)
}
and copy_private_flag :
Ast_500.Asttypes.private_flag -> Ast_414.Asttypes.private_flag =
function
| Ast_500.Asttypes.Private -> Ast_414.Asttypes.Private
| Ast_500.Asttypes.Public -> Ast_414.Asttypes.Public
and copy_out_rec_status :
Ast_500.Outcometree.out_rec_status -> Ast_414.Outcometree.out_rec_status =
function
| Ast_500.Outcometree.Orec_not -> Ast_414.Outcometree.Orec_not
| Ast_500.Outcometree.Orec_first -> Ast_414.Outcometree.Orec_first
| Ast_500.Outcometree.Orec_next -> Ast_414.Outcometree.Orec_next
and copy_out_class_type :
Ast_500.Outcometree.out_class_type -> Ast_414.Outcometree.out_class_type =
function
| Ast_500.Outcometree.Octy_constr (x0, x1) ->
Ast_414.Outcometree.Octy_constr
((copy_out_ident x0), (List.map copy_out_type x1))
| Ast_500.Outcometree.Octy_arrow (x0, x1, x2) ->
Ast_414.Outcometree.Octy_arrow
(x0, (copy_out_type x1), (copy_out_class_type x2))
| Ast_500.Outcometree.Octy_signature (x0, x1) ->
Ast_414.Outcometree.Octy_signature
((Option.map copy_out_type x0),
(List.map copy_out_class_sig_item x1))
and copy_out_class_sig_item :
Ast_500.Outcometree.out_class_sig_item ->
Ast_414.Outcometree.out_class_sig_item
=
function
| Ast_500.Outcometree.Ocsg_constraint (x0, x1) ->
Ast_414.Outcometree.Ocsg_constraint
((copy_out_type x0), (copy_out_type x1))
| Ast_500.Outcometree.Ocsg_method (x0, x1, x2, x3) ->
Ast_414.Outcometree.Ocsg_method (x0, x1, x2, (copy_out_type x3))
| Ast_500.Outcometree.Ocsg_value (x0, x1, x2, x3) ->
Ast_414.Outcometree.Ocsg_value (x0, x1, x2, (copy_out_type x3))
and copy_out_type_param :
Ast_500.Outcometree.out_type_param -> Ast_414.Outcometree.out_type_param =
fun x ->
let (x0, x1) = x in
(x0, (let (x0, x1) = x1 in ((copy_variance x0), (copy_injectivity x1))))
and copy_injectivity :
Ast_500.Asttypes.injectivity -> Ast_414.Asttypes.injectivity =
function
| Ast_500.Asttypes.Injective -> Ast_414.Asttypes.Injective
| Ast_500.Asttypes.NoInjectivity -> Ast_414.Asttypes.NoInjectivity
and copy_variance : Ast_500.Asttypes.variance -> Ast_414.Asttypes.variance =
function
| Ast_500.Asttypes.Covariant -> Ast_414.Asttypes.Covariant
| Ast_500.Asttypes.Contravariant -> Ast_414.Asttypes.Contravariant
| Ast_500.Asttypes.NoVariance -> Ast_414.Asttypes.NoVariance
and copy_out_type :
Ast_500.Outcometree.out_type -> Ast_414.Outcometree.out_type =
function
| Ast_500.Outcometree.Otyp_abstract -> Ast_414.Outcometree.Otyp_abstract
| Ast_500.Outcometree.Otyp_open -> Ast_414.Outcometree.Otyp_open
| Ast_500.Outcometree.Otyp_alias (x0, x1) ->
Ast_414.Outcometree.Otyp_alias ((copy_out_type x0), x1)
| Ast_500.Outcometree.Otyp_arrow (x0, x1, x2) ->
Ast_414.Outcometree.Otyp_arrow
(x0, (copy_out_type x1), (copy_out_type x2))
| Ast_500.Outcometree.Otyp_class (x0, x1, x2) ->
Ast_414.Outcometree.Otyp_class
(x0, (copy_out_ident x1), (List.map copy_out_type x2))
| Ast_500.Outcometree.Otyp_constr (x0, x1) ->
Ast_414.Outcometree.Otyp_constr
((copy_out_ident x0), (List.map copy_out_type x1))
| Ast_500.Outcometree.Otyp_manifest (x0, x1) ->
Ast_414.Outcometree.Otyp_manifest
((copy_out_type x0), (copy_out_type x1))
| Ast_500.Outcometree.Otyp_object (x0, x1) ->
Ast_414.Outcometree.Otyp_object
((List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1))) x0),
(Option.map (fun x -> x) x1))
| Ast_500.Outcometree.Otyp_record x0 ->
Ast_414.Outcometree.Otyp_record
(List.map
(fun x -> let (x0, x1, x2) = x in (x0, x1, (copy_out_type x2))) x0)
| Ast_500.Outcometree.Otyp_stuff x0 -> Ast_414.Outcometree.Otyp_stuff x0
| Ast_500.Outcometree.Otyp_sum x0 ->
Ast_414.Outcometree.Otyp_sum (List.map copy_out_constructor x0)
| Ast_500.Outcometree.Otyp_tuple x0 ->
Ast_414.Outcometree.Otyp_tuple (List.map copy_out_type x0)
| Ast_500.Outcometree.Otyp_var (x0, x1) ->
Ast_414.Outcometree.Otyp_var (x0, x1)
| Ast_500.Outcometree.Otyp_variant (x0, x1, x2, x3) ->
Ast_414.Outcometree.Otyp_variant
(x0, (copy_out_variant x1), x2,
(Option.map (fun x -> List.map (fun x -> x) x) x3))
| Ast_500.Outcometree.Otyp_poly (x0, x1) ->
Ast_414.Outcometree.Otyp_poly
((List.map (fun x -> x) x0), (copy_out_type x1))
| Ast_500.Outcometree.Otyp_module (x0, x1) ->
Ast_414.Outcometree.Otyp_module
((copy_out_ident x0),
(List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1)))
x1))
| Ast_500.Outcometree.Otyp_attribute (x0, x1) ->
Ast_414.Outcometree.Otyp_attribute
((copy_out_type x0), (copy_out_attribute x1))
and copy_out_attribute :
Ast_500.Outcometree.out_attribute -> Ast_414.Outcometree.out_attribute =
fun { Ast_500.Outcometree.oattr_name = oattr_name } ->
{ Ast_414.Outcometree.oattr_name = oattr_name }
and copy_out_variant :
Ast_500.Outcometree.out_variant -> Ast_414.Outcometree.out_variant =
function
| Ast_500.Outcometree.Ovar_fields x0 ->
Ast_414.Outcometree.Ovar_fields
(List.map
(fun x ->
let (x0, x1, x2) = x in (x0, x1, (List.map copy_out_type x2)))
x0)
| Ast_500.Outcometree.Ovar_typ x0 ->
Ast_414.Outcometree.Ovar_typ (copy_out_type x0)
and copy_out_constructor :
Ast_500.Outcometree.out_constructor -> Ast_414.Outcometree.out_constructor
=
fun
{ Ast_500.Outcometree.ocstr_name = ocstr_name;
Ast_500.Outcometree.ocstr_args = ocstr_args;
Ast_500.Outcometree.ocstr_return_type = ocstr_return_type }
->
{
Ast_414.Outcometree.ocstr_name = ocstr_name;
Ast_414.Outcometree.ocstr_args = (List.map copy_out_type ocstr_args);
Ast_414.Outcometree.ocstr_return_type =
(Option.map copy_out_type ocstr_return_type)
}
and copy_out_value :
Ast_500.Outcometree.out_value -> Ast_414.Outcometree.out_value =
function
| Ast_500.Outcometree.Oval_array x0 ->
Ast_414.Outcometree.Oval_array (List.map copy_out_value x0)
| Ast_500.Outcometree.Oval_char x0 -> Ast_414.Outcometree.Oval_char x0
| Ast_500.Outcometree.Oval_constr (x0, x1) ->
Ast_414.Outcometree.Oval_constr
((copy_out_ident x0), (List.map copy_out_value x1))
| Ast_500.Outcometree.Oval_ellipsis -> Ast_414.Outcometree.Oval_ellipsis
| Ast_500.Outcometree.Oval_float x0 -> Ast_414.Outcometree.Oval_float x0
| Ast_500.Outcometree.Oval_int x0 -> Ast_414.Outcometree.Oval_int x0
| Ast_500.Outcometree.Oval_int32 x0 -> Ast_414.Outcometree.Oval_int32 x0
| Ast_500.Outcometree.Oval_int64 x0 -> Ast_414.Outcometree.Oval_int64 x0
| Ast_500.Outcometree.Oval_nativeint x0 ->
Ast_414.Outcometree.Oval_nativeint x0
| Ast_500.Outcometree.Oval_list x0 ->
Ast_414.Outcometree.Oval_list (List.map copy_out_value x0)
| Ast_500.Outcometree.Oval_printer x0 ->
Ast_414.Outcometree.Oval_printer x0
| Ast_500.Outcometree.Oval_record x0 ->
Ast_414.Outcometree.Oval_record
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_ident x0), (copy_out_value x1)))
x0)
| Ast_500.Outcometree.Oval_string (x0, x1, x2) ->
Ast_414.Outcometree.Oval_string (x0, x1, (copy_out_string x2))
| Ast_500.Outcometree.Oval_stuff x0 -> Ast_414.Outcometree.Oval_stuff x0
| Ast_500.Outcometree.Oval_tuple x0 ->
Ast_414.Outcometree.Oval_tuple (List.map copy_out_value x0)
| Ast_500.Outcometree.Oval_variant (x0, x1) ->
Ast_414.Outcometree.Oval_variant (x0, (Option.map copy_out_value x1))
and copy_out_string :
Ast_500.Outcometree.out_string -> Ast_414.Outcometree.out_string =
function
| Ast_500.Outcometree.Ostr_string -> Ast_414.Outcometree.Ostr_string
| Ast_500.Outcometree.Ostr_bytes -> Ast_414.Outcometree.Ostr_bytes
and copy_out_ident :
Ast_500.Outcometree.out_ident -> Ast_414.Outcometree.out_ident =
function
| Ast_500.Outcometree.Oide_apply (x0, x1) ->
Ast_414.Outcometree.Oide_apply
((copy_out_ident x0), (copy_out_ident x1))
| Ast_500.Outcometree.Oide_dot (x0, x1) ->
Ast_414.Outcometree.Oide_dot ((copy_out_ident x0), x1)
| Ast_500.Outcometree.Oide_ident x0 ->
Ast_414.Outcometree.Oide_ident (copy_out_name x0)
and copy_out_name :
Ast_500.Outcometree.out_name -> Ast_414.Outcometree.out_name =
fun { Ast_500.Outcometree.printed_name = printed_name } ->
{ Ast_414.Outcometree.printed_name = printed_name }
================================================
FILE: src/vendored-omp/src/migrate_parsetree_500_51.ml
================================================
(**************************************************************************)
(* *)
(* OCaml Migrate Parsetree *)
(* *)
(* Frédéric Bour *)
(* *)
(* Copyright 2017 Institut National de Recherche en Informatique et *)
(* en Automatique (INRIA). *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
include Migrate_parsetree_500_51_migrate
================================================
FILE: src/vendored-omp/src/migrate_parsetree_500_51_migrate.ml
================================================
open Stdlib0
module From = Ast_500
module To = Ast_51
let rec copy_out_type_extension :
Ast_500.Outcometree.out_type_extension ->
Ast_51.Outcometree.out_type_extension
=
fun
{ Ast_500.Outcometree.otyext_name = otyext_name;
Ast_500.Outcometree.otyext_params = otyext_params;
Ast_500.Outcometree.otyext_constructors = otyext_constructors;
Ast_500.Outcometree.otyext_private = otyext_private }
->
{
Ast_51.Outcometree.otyext_name = otyext_name;
Ast_51.Outcometree.otyext_params =
(List.map (fun x -> x) otyext_params);
Ast_51.Outcometree.otyext_constructors =
(List.map copy_out_constructor otyext_constructors);
Ast_51.Outcometree.otyext_private = (copy_private_flag otyext_private)
}
and copy_out_phrase :
Ast_500.Outcometree.out_phrase -> Ast_51.Outcometree.out_phrase =
function
| Ast_500.Outcometree.Ophr_eval (x0, x1) ->
Ast_51.Outcometree.Ophr_eval ((copy_out_value x0), (copy_out_type x1))
| Ast_500.Outcometree.Ophr_signature x0 ->
Ast_51.Outcometree.Ophr_signature
(List.map
(fun x ->
let (x0, x1) = x in
((copy_out_sig_item x0), (Option.map copy_out_value x1))) x0)
| Ast_500.Outcometree.Ophr_exception x0 ->
Ast_51.Outcometree.Ophr_exception
(let (x0, x1) = x0 in (x0, (copy_out_value x1)))
and copy_out_sig_item :
Ast_500.Outcometree.out_sig_item -> Ast_51.Outcometree.out_sig_item =
function
| Ast_500.Outcometree.Osig_class (x0, x1, x2, x3, x4) ->
Ast_51.Outcometree.Osig_class
(x0, x1, (List.map copy_out_type_param x2), (copy_out_class_type x3),
(copy_out_rec_status x4))
| Ast_500.Outcometree.Osig_class_type (x0, x1, x2, x3, x4) ->
Ast_51.Outcometree.Osig_class_type
(x0, x1, (List.map copy_out_type_param x2), (copy_out_class_type x3),
(copy_out_rec_status x4))
| Ast_500.Outcometree.Osig_typext (x0, x1) ->
Ast_51.Outcometree.Osig_typext
((copy_out_extension_constructor x0), (copy_out_ext_status x1))
| Ast_500.Outcometree.Osig_modtype (x0, x1) ->
Ast_51.Outcometree.Osig_modtype (x0, (copy_out_module_type x1))
| Ast_500.Outcometree.Osig_module (x0, x1, x2) ->
Ast_51.Outcometree.Osig_module
(x0, (copy_out_module_type x1), (copy_out_rec_status x2))
| Ast_500.Outcometree.Osig_type (x0, x1) ->
Ast_51.Outcometree.Osig_type
((copy_out_type_decl x0), (copy_out_rec_status x1))
| Ast_500.Outcometree.Osig_value x0 ->
Ast_51.Outcometree.Osig_value (copy_out_val_decl x0)
| Ast_500.Outcometree.Osig_ellipsis -> Ast_51.Outcometree.Osig_ellipsis
and copy_out_val_decl :
Ast_500.Outcometree.out_val_decl -> Ast_51.Outcometree.out_val_decl =
fun
{ Ast_500.Outcometree.oval_name = oval_name;
Ast_500.Outcometree.oval_type = oval_type;
Ast_500.Outcometree.oval_prims = oval_prims;
Ast_500.Outcometree.oval_attributes = oval_attributes }
->
{
Ast_51.Outcometree.oval_name = oval_name;
Ast_51.Outcometree.oval_type = (copy_out_type oval_type);
Ast_51.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims);
Ast_51.Outcometree.oval_attributes =
(List.map copy_out_attribute oval_attributes)
}
and copy_out_type_decl :
Ast_500.Outcometree.out_type_decl -> Ast_51.Outcometree.out_type_decl =
fun
{ Ast_500.Outcometree.otype_name = otype_name;
Ast_500.Outcometree.otype_params = otype_params;
Ast_500.Outcometree.otype_type = otype_type;
Ast_500.Outcometree.otype_private = otype_private;
Ast_500.Outcometree.otype_immediate = otype_immediate;
Ast_500.Outcometree.otype_unboxed = otype_unboxed;
Ast_500.Outcometree.otype_cstrs = otype_cstrs }
->
{
Ast_51.Outcometree.otype_name = otype_name;
Ast_51.Outcometree.otype_params =
(List.map copy_out_type_param otype_params);
Ast_51.Outcometree.otype_type = (copy_out_type otype_type);
Ast_51.Outcometree.otype_private = (copy_private_flag otype_private);
Ast_51.Outcometree.otype_immediate =
(copy_Type_immediacy_t otype_immediate);
Ast_51.Outcometree.otype_unboxed = otype_unboxed;
Ast_51.Outcometree.otype_cstrs =
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_type x0), (copy_out_type x1)))
otype_cstrs)
}
and copy_Type_immediacy_t :
Ast_500.Type_immediacy.t -> Ast_51.Type_immediacy.t =
function
| Ast_500.Type_immediacy.Unknown -> Ast_51.Type_immediacy.Unknown
| Ast_500.Type_immediacy.Always -> Ast_51.Type_immediacy.Always
| Ast_500.Type_immediacy.Always_on_64bits ->
Ast_51.Type_immediacy.Always_on_64bits
and copy_out_module_type :
Ast_500.Outcometree.out_module_type -> Ast_51.Outcometree.out_module_type =
function
| Ast_500.Outcometree.Omty_abstract -> Ast_51.Outcometree.Omty_abstract
| Ast_500.Outcometree.Omty_functor (x0, x1) ->
Ast_51.Outcometree.Omty_functor
((Option.map
(fun x ->
let (x0, x1) = x in
((Option.map (fun x -> x) x0), (copy_out_module_type x1))) x0),
(copy_out_module_type x1))
| Ast_500.Outcometree.Omty_ident x0 ->
Ast_51.Outcometree.Omty_ident (copy_out_ident x0)
| Ast_500.Outcometree.Omty_signature x0 ->
Ast_51.Outcometree.Omty_signature (List.map copy_out_sig_item x0)
| Ast_500.Outcometree.Omty_alias x0 ->
Ast_51.Outcometree.Omty_alias (copy_out_ident x0)
and copy_out_ext_status :
Ast_500.Outcometree.out_ext_status -> Ast_51.Outcometree.out_ext_status =
function
| Ast_500.Outcometree.Oext_first -> Ast_51.Outcometree.Oext_first
| Ast_500.Outcometree.Oext_next -> Ast_51.Outcometree.Oext_next
| Ast_500.Outcometree.Oext_exception -> Ast_51.Outcometree.Oext_exception
and copy_out_extension_constructor :
Ast_500.Outcometree.out_extension_constructor ->
Ast_51.Outcometree.out_extension_constructor
=
fun
{ Ast_500.Outcometree.oext_name = oext_name;
Ast_500.Outcometree.oext_type_name = oext_type_name;
Ast_500.Outcometree.oext_type_params = oext_type_params;
Ast_500.Outcometree.oext_args = oext_args;
Ast_500.Outcometree.oext_ret_type = oext_ret_type;
Ast_500.Outcometree.oext_private = oext_private }
->
{
Ast_51.Outcometree.oext_name = oext_name;
Ast_51.Outcometree.oext_type_name = oext_type_name;
Ast_51.Outcometree.oext_type_params =
(List.map (fun x -> x) oext_type_params);
Ast_51.Outcometree.oext_args = (List.map copy_out_type oext_args);
Ast_51.Outcometree.oext_ret_type =
(Option.map copy_out_type oext_ret_type);
Ast_51.Outcometree.oext_private = (copy_private_flag oext_private)
}
and copy_private_flag :
Ast_500.Asttypes.private_flag -> Ast_51.Asttypes.private_flag =
function
| Ast_500.Asttypes.Private -> Ast_51.Asttypes.Private
| Ast_500.Asttypes.Public -> Ast_51.Asttypes.Public
and copy_out_rec_status :
Ast_500.Outcometree.out_rec_status -> Ast_51.Outcometree.out_rec_status =
function
| Ast_500.Outcometree.Orec_not -> Ast_51.Outcometree.Orec_not
| Ast_500.Outcometree.Orec_first -> Ast_51.Outcometree.Orec_first
| Ast_500.Outcometree.Orec_next -> Ast_51.Outcometree.Orec_next
and copy_out_class_type :
Ast_500.Outcometree.out_class_type -> Ast_51.Outcometree.out_class_type =
function
| Ast_500.Outcometree.Octy_constr (x0, x1) ->
Ast_51.Outcometree.Octy_constr
((copy_out_ident x0), (List.map copy_out_type x1))
| Ast_500.Outcometree.Octy_arrow (x0, x1, x2) ->
Ast_51.Outcometree.Octy_arrow
(x0, (copy_out_type x1), (copy_out_class_type x2))
| Ast_500.Outcometree.Octy_signature (x0, x1) ->
Ast_51.Outcometree.Octy_signature
((Option.map copy_out_type x0),
(List.map copy_out_class_sig_item x1))
and copy_out_class_sig_item :
Ast_500.Outcometree.out_class_sig_item ->
Ast_51.Outcometree.out_class_sig_item
=
function
| Ast_500.Outcometree.Ocsg_constraint (x0, x1) ->
Ast_51.Outcometree.Ocsg_constraint
((copy_out_type x0), (copy_out_type x1))
| Ast_500.Outcometree.Ocsg_method (x0, x1, x2, x3) ->
Ast_51.Outcometree.Ocsg_method (x0, x1, x2, (copy_out_type x3))
| Ast_500.Outcometree.Ocsg_value (x0, x1, x2, x3) ->
Ast_51.Outcometree.Ocsg_value (x0, x1, x2, (copy_out_type x3))
and copy_out_type_param :
Ast_500.Outcometree.out_type_param -> Ast_51.Outcometree.out_type_param =
fun x ->
let (x0, x1) = x in
(x0, (let (x0, x1) = x1 in ((copy_variance x0), (copy_injectivity x1))))
and copy_injectivity :
Ast_500.Asttypes.injectivity -> Ast_51.Asttypes.injectivity =
function
| Ast_500.Asttypes.Injective -> Ast_51.Asttypes.Injective
| Ast_500.Asttypes.NoInjectivity -> Ast_51.Asttypes.NoInjectivity
and copy_variance : Ast_500.Asttypes.variance -> Ast_51.Asttypes.variance =
function
| Ast_500.Asttypes.Covariant -> Ast_51.Asttypes.Covariant
| Ast_500.Asttypes.Contravariant -> Ast_51.Asttypes.Contravariant
| Ast_500.Asttypes.NoVariance -> Ast_51.Asttypes.NoVariance
and copy_out_type :
Ast_500.Outcometree.out_type -> Ast_51.Outcometree.out_type =
function
| Ast_500.Outcometree.Otyp_abstract -> Ast_51.Outcometree.Otyp_abstract
| Ast_500.Outcometree.Otyp_open -> Ast_51.Outcometree.Otyp_open
| Ast_500.Outcometree.Otyp_alias (x0, x1) ->
Ast_51.Outcometree.Otyp_alias {non_gen=false;aliased=(copy_out_type x0);alias=x1}
| Ast_500.Outcometree.Otyp_arrow (x0, x1, x2) ->
Ast_51.Outcometree.Otyp_arrow
(x0, (copy_out_type x1), (copy_out_type x2))
| Ast_500.Outcometree.Otyp_class (_x0, x1, x2) ->
Ast_51.Outcometree.Otyp_class
((copy_out_ident x1), (List.map copy_out_type x2))
| Ast_500.Outcometree.Otyp_constr (x0, x1) ->
Ast_51.Outcometree.Otyp_constr
((copy_out_ident x0), (List.map copy_out_type x1))
| Ast_500.Outcometree.Otyp_manifest (x0, x1) ->
Ast_51.Outcometree.Otyp_manifest
((copy_out_type x0), (copy_out_type x1))
| Ast_500.Outcometree.Otyp_object (x0, x1) ->
Ast_51.Outcometree.Otyp_object
{fields=(List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1))) x0);
open_row=match x1 with None -> false | Some b ->b}
| Ast_500.Outcometree.Otyp_record x0 ->
Ast_51.Outcometree.Otyp_record
(List.map
(fun x -> let (x0, x1, x2) = x in (x0, x1, (copy_out_type x2))) x0)
| Ast_500.Outcometree.Otyp_stuff x0 -> Ast_51.Outcometree.Otyp_stuff x0
| Ast_500.Outcometree.Otyp_sum x0 ->
Ast_51.Outcometree.Otyp_sum (List.map copy_out_constructor x0)
| Ast_500.Outcometree.Otyp_tuple x0 ->
Ast_51.Outcometree.Otyp_tuple (List.map copy_out_type x0)
| Ast_500.Outcometree.Otyp_var (x0, x1) ->
Ast_51.Outcometree.Otyp_var (x0, x1)
| Ast_500.Outcometree.Otyp_variant (_x0, x1, x2, x3) ->
Ast_51.Outcometree.Otyp_variant
((copy_out_variant x1), x2,
(Option.map (fun x -> List.map (fun x -> x) x) x3))
| Ast_500.Outcometree.Otyp_poly (x0, x1) ->
Ast_51.Outcometree.Otyp_poly
((List.map (fun x -> x) x0), (copy_out_type x1))
| Ast_500.Outcometree.Otyp_module (x0, x1) ->
Ast_51.Outcometree.Otyp_module
((copy_out_ident x0),
(List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1)))
x1))
| Ast_500.Outcometree.Otyp_attribute (x0, x1) ->
Ast_51.Outcometree.Otyp_attribute
((copy_out_type x0), (copy_out_attribute x1))
and copy_out_attribute :
Ast_500.Outcometree.out_attribute -> Ast_51.Outcometree.out_attribute =
fun { Ast_500.Outcometree.oattr_name = oattr_name } ->
{ Ast_51.Outcometree.oattr_name = oattr_name }
and copy_out_variant :
Ast_500.Outcometree.out_variant -> Ast_51.Outcometree.out_variant =
function
| Ast_500.Outcometree.Ovar_fields x0 ->
Ast_51.Outcometree.Ovar_fields
(List.map
(fun x ->
let (x0, x1, x2) = x in (x0, x1, (List.map copy_out_type x2)))
x0)
| Ast_500.Outcometree.Ovar_typ x0 ->
Ast_51.Outcometree.Ovar_typ (copy_out_type x0)
and copy_out_constructor :
Ast_500.Outcometree.out_constructor -> Ast_51.Outcometree.out_constructor =
fun
{ Ast_500.Outcometree.ocstr_name = ocstr_name;
Ast_500.Outcometree.ocstr_args = ocstr_args;
Ast_500.Outcometree.ocstr_return_type = ocstr_return_type }
->
{
Ast_51.Outcometree.ocstr_name = ocstr_name;
Ast_51.Outcometree.ocstr_args = (List.map copy_out_type ocstr_args);
Ast_51.Outcometree.ocstr_return_type =
(Option.map copy_out_type ocstr_return_type)
}
and copy_out_value :
Ast_500.Outcometree.out_value -> Ast_51.Outcometree.out_value =
function
| Ast_500.Outcometree.Oval_array x0 ->
Ast_51.Outcometree.Oval_array (List.map copy_out_value x0)
| Ast_500.Outcometree.Oval_char x0 -> Ast_51.Outcometree.Oval_char x0
| Ast_500.Outcometree.Oval_constr (x0, x1) ->
Ast_51.Outcometree.Oval_constr
((copy_out_ident x0), (List.map copy_out_value x1))
| Ast_500.Outcometree.Oval_ellipsis -> Ast_51.Outcometree.Oval_ellipsis
| Ast_500.Outcometree.Oval_float x0 -> Ast_51.Outcometree.Oval_float x0
| Ast_500.Outcometree.Oval_int x0 -> Ast_51.Outcometree.Oval_int x0
| Ast_500.Outcometree.Oval_int32 x0 -> Ast_51.Outcometree.Oval_int32 x0
| Ast_500.Outcometree.Oval_int64 x0 -> Ast_51.Outcometree.Oval_int64 x0
| Ast_500.Outcometree.Oval_nativeint x0 ->
Ast_51.Outcometree.Oval_nativeint x0
| Ast_500.Outcometree.Oval_list x0 ->
Ast_51.Outcometree.Oval_list (List.map copy_out_value x0)
| Ast_500.Outcometree.Oval_printer x0 -> Ast_51.Outcometree.Oval_printer x0
| Ast_500.Outcometree.Oval_record x0 ->
Ast_51.Outcometree.Oval_record
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_ident x0), (copy_out_value x1)))
x0)
| Ast_500.Outcometree.Oval_string (x0, x1, x2) ->
Ast_51.Outcometree.Oval_string (x0, x1, (copy_out_string x2))
| Ast_500.Outcometree.Oval_stuff x0 -> Ast_51.Outcometree.Oval_stuff x0
| Ast_500.Outcometree.Oval_tuple x0 ->
Ast_51.Outcometree.Oval_tuple (List.map copy_out_value x0)
| Ast_500.Outcometree.Oval_variant (x0, x1) ->
Ast_51.Outcometree.Oval_variant (x0, (Option.map copy_out_value x1))
and copy_out_string :
Ast_500.Outcometree.out_string -> Ast_51.Outcometree.out_string =
function
| Ast_500.Outcometree.Ostr_string -> Ast_51.Outcometree.Ostr_string
| Ast_500.Outcometree.Ostr_bytes -> Ast_51.Outcometree.Ostr_bytes
and copy_out_ident :
Ast_500.Outcometree.out_ident -> Ast_51.Outcometree.out_ident =
function
| Ast_500.Outcometree.Oide_apply (x0, x1) ->
Ast_51.Outcometree.Oide_apply
((copy_out_ident x0), (copy_out_ident x1))
| Ast_500.Outcometree.Oide_dot (x0, x1) ->
Ast_51.Outcometree.Oide_dot ((copy_out_ident x0), x1)
| Ast_500.Outcometree.Oide_ident x0 ->
Ast_51.Outcometree.Oide_ident (copy_out_name x0)
and copy_out_name :
Ast_500.Outcometree.out_name -> Ast_51.Outcometree.out_name =
fun { Ast_500.Outcometree.printed_name = printed_name } ->
{ Ast_51.Outcometree.printed_name = printed_name }
================================================
FILE: src/vendored-omp/src/migrate_parsetree_51_500.ml
================================================
(**************************************************************************)
(* *)
(* OCaml Migrate Parsetree *)
(* *)
(* Frédéric Bour *)
(* *)
(* Copyright 2017 Institut National de Recherche en Informatique et *)
(* en Automatique (INRIA). *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
include Migrate_parsetree_51_500_migrate
================================================
FILE: src/vendored-omp/src/migrate_parsetree_51_500_migrate.ml
================================================
open Stdlib0
module From = Ast_51
module To = Ast_500
let rec copy_out_type_extension :
Ast_51.Outcometree.out_type_extension ->
Ast_500.Outcometree.out_type_extension
=
fun
{ Ast_51.Outcometree.otyext_name = otyext_name;
Ast_51.Outcometree.otyext_params = otyext_params;
Ast_51.Outcometree.otyext_constructors = otyext_constructors;
Ast_51.Outcometree.otyext_private = otyext_private }
->
{
Ast_500.Outcometree.otyext_name = otyext_name;
Ast_500.Outcometree.otyext_params =
(List.map (fun x -> x) otyext_params);
Ast_500.Outcometree.otyext_constructors =
(List.map copy_out_constructor otyext_constructors);
Ast_500.Outcometree.otyext_private = (copy_private_flag otyext_private)
}
and copy_out_phrase :
Ast_51.Outcometree.out_phrase -> Ast_500.Outcometree.out_phrase =
function
| Ast_51.Outcometree.Ophr_eval (x0, x1) ->
Ast_500.Outcometree.Ophr_eval ((copy_out_value x0), (copy_out_type x1))
| Ast_51.Outcometree.Ophr_signature x0 ->
Ast_500.Outcometree.Ophr_signature
(List.map
(fun x ->
let (x0, x1) = x in
((copy_out_sig_item x0), (Option.map copy_out_value x1))) x0)
| Ast_51.Outcometree.Ophr_exception x0 ->
Ast_500.Outcometree.Ophr_exception
(let (x0, x1) = x0 in (x0, (copy_out_value x1)))
and copy_out_sig_item :
Ast_51.Outcometree.out_sig_item -> Ast_500.Outcometree.out_sig_item =
function
| Ast_51.Outcometree.Osig_class (x0, x1, x2, x3, x4) ->
Ast_500.Outcometree.Osig_class
(x0, x1, (List.map copy_out_type_param x2), (copy_out_class_type x3),
(copy_out_rec_status x4))
| Ast_51.Outcometree.Osig_class_type (x0, x1, x2, x3, x4) ->
Ast_500.Outcometree.Osig_class_type
(x0, x1, (List.map copy_out_type_param x2), (copy_out_class_type x3),
(copy_out_rec_status x4))
| Ast_51.Outcometree.Osig_typext (x0, x1) ->
Ast_500.Outcometree.Osig_typext
((copy_out_extension_constructor x0), (copy_out_ext_status x1))
| Ast_51.Outcometree.Osig_modtype (x0, x1) ->
Ast_500.Outcometree.Osig_modtype (x0, (copy_out_module_type x1))
| Ast_51.Outcometree.Osig_module (x0, x1, x2) ->
Ast_500.Outcometree.Osig_module
(x0, (copy_out_module_type x1), (copy_out_rec_status x2))
| Ast_51.Outcometree.Osig_type (x0, x1) ->
Ast_500.Outcometree.Osig_type
((copy_out_type_decl x0), (copy_out_rec_status x1))
| Ast_51.Outcometree.Osig_value x0 ->
Ast_500.Outcometree.Osig_value (copy_out_val_decl x0)
| Ast_51.Outcometree.Osig_ellipsis -> Ast_500.Outcometree.Osig_ellipsis
and copy_out_val_decl :
Ast_51.Outcometree.out_val_decl -> Ast_500.Outcometree.out_val_decl =
fun
{ Ast_51.Outcometree.oval_name = oval_name;
Ast_51.Outcometree.oval_type = oval_type;
Ast_51.Outcometree.oval_prims = oval_prims;
Ast_51.Outcometree.oval_attributes = oval_attributes }
->
{
Ast_500.Outcometree.oval_name = oval_name;
Ast_500.Outcometree.oval_type = (copy_out_type oval_type);
Ast_500.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims);
Ast_500.Outcometree.oval_attributes =
(List.map copy_out_attribute oval_attributes)
}
and copy_out_type_decl :
Ast_51.Outcometree.out_type_decl -> Ast_500.Outcometree.out_type_decl =
fun
{ Ast_51.Outcometree.otype_name = otype_name;
Ast_51.Outcometree.otype_params = otype_params;
Ast_51.Outcometree.otype_type = otype_type;
Ast_51.Outcometree.otype_private = otype_private;
Ast_51.Outcometree.otype_immediate = otype_immediate;
Ast_51.Outcometree.otype_unboxed = otype_unboxed;
Ast_51.Outcometree.otype_cstrs = otype_cstrs }
->
{
Ast_500.Outcometree.otype_name = otype_name;
Ast_500.Outcometree.otype_params =
(List.map copy_out_type_param otype_params);
Ast_500.Outcometree.otype_type = (copy_out_type otype_type);
Ast_500.Outcometree.otype_private = (copy_private_flag otype_private);
Ast_500.Outcometree.otype_immediate =
(copy_Type_immediacy_t otype_immediate);
Ast_500.Outcometree.otype_unboxed = otype_unboxed;
Ast_500.Outcometree.otype_cstrs =
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_type x0), (copy_out_type x1)))
otype_cstrs)
}
and copy_Type_immediacy_t :
Ast_51.Type_immediacy.t -> Ast_500.Type_immediacy.t =
function
| Ast_51.Type_immediacy.Unknown -> Ast_500.Type_immediacy.Unknown
| Ast_51.Type_immediacy.Always -> Ast_500.Type_immediacy.Always
| Ast_51.Type_immediacy.Always_on_64bits ->
Ast_500.Type_immediacy.Always_on_64bits
and copy_out_module_type :
Ast_51.Outcometree.out_module_type -> Ast_500.Outcometree.out_module_type =
function
| Ast_51.Outcometree.Omty_abstract -> Ast_500.Outcometree.Omty_abstract
| Ast_51.Outcometree.Omty_functor (x0, x1) ->
Ast_500.Outcometree.Omty_functor
((Option.map
(fun x ->
let (x0, x1) = x in
((Option.map (fun x -> x) x0), (copy_out_module_type x1))) x0),
(copy_out_module_type x1))
| Ast_51.Outcometree.Omty_ident x0 ->
Ast_500.Outcometree.Omty_ident (copy_out_ident x0)
| Ast_51.Outcometree.Omty_signature x0 ->
Ast_500.Outcometree.Omty_signature (List.map copy_out_sig_item x0)
| Ast_51.Outcometree.Omty_alias x0 ->
Ast_500.Outcometree.Omty_alias (copy_out_ident x0)
and copy_out_ext_status :
Ast_51.Outcometree.out_ext_status -> Ast_500.Outcometree.out_ext_status =
function
| Ast_51.Outcometree.Oext_first -> Ast_500.Outcometree.Oext_first
| Ast_51.Outcometree.Oext_next -> Ast_500.Outcometree.Oext_next
| Ast_51.Outcometree.Oext_exception -> Ast_500.Outcometree.Oext_exception
and copy_out_extension_constructor :
Ast_51.Outcometree.out_extension_constructor ->
Ast_500.Outcometree.out_extension_constructor
=
fun
{ Ast_51.Outcometree.oext_name = oext_name;
Ast_51.Outcometree.oext_type_name = oext_type_name;
Ast_51.Outcometree.oext_type_params = oext_type_params;
Ast_51.Outcometree.oext_args = oext_args;
Ast_51.Outcometree.oext_ret_type = oext_ret_type;
Ast_51.Outcometree.oext_private = oext_private }
->
{
Ast_500.Outcometree.oext_name = oext_name;
Ast_500.Outcometree.oext_type_name = oext_type_name;
Ast_500.Outcometree.oext_type_params =
(List.map (fun x -> x) oext_type_params);
Ast_500.Outcometree.oext_args = (List.map copy_out_type oext_args);
Ast_500.Outcometree.oext_ret_type =
(Option.map copy_out_type oext_ret_type);
Ast_500.Outcometree.oext_private = (copy_private_flag oext_private)
}
and copy_private_flag :
Ast_51.Asttypes.private_flag -> Ast_500.Asttypes.private_flag =
function
| Ast_51.Asttypes.Private -> Ast_500.Asttypes.Private
| Ast_51.Asttypes.Public -> Ast_500.Asttypes.Public
and copy_out_rec_status :
Ast_51.Outcometree.out_rec_status -> Ast_500.Outcometree.out_rec_status =
function
| Ast_51.Outcometree.Orec_not -> Ast_500.Outcometree.Orec_not
| Ast_51.Outcometree.Orec_first -> Ast_500.Outcometree.Orec_first
| Ast_51.Outcometree.Orec_next -> Ast_500.Outcometree.Orec_next
and copy_out_class_type :
Ast_51.Outcometree.out_class_type -> Ast_500.Outcometree.out_class_type =
function
| Ast_51.Outcometree.Octy_constr (x0, x1) ->
Ast_500.Outcometree.Octy_constr
((copy_out_ident x0), (List.map copy_out_type x1))
| Ast_51.Outcometree.Octy_arrow (x0, x1, x2) ->
Ast_500.Outcometree.Octy_arrow
(x0, (copy_out_type x1), (copy_out_class_type x2))
| Ast_51.Outcometree.Octy_signature (x0, x1) ->
Ast_500.Outcometree.Octy_signature
((Option.map copy_out_type x0),
(List.map copy_out_class_sig_item x1))
and copy_out_class_sig_item :
Ast_51.Outcometree.out_class_sig_item ->
Ast_500.Outcometree.out_class_sig_item
=
function
| Ast_51.Outcometree.Ocsg_constraint (x0, x1) ->
Ast_500.Outcometree.Ocsg_constraint
((copy_out_type x0), (copy_out_type x1))
| Ast_51.Outcometree.Ocsg_method (x0, x1, x2, x3) ->
Ast_500.Outcometree.Ocsg_method (x0, x1, x2, (copy_out_type x3))
| Ast_51.Outcometree.Ocsg_value (x0, x1, x2, x3) ->
Ast_500.Outcometree.Ocsg_value (x0, x1, x2, (copy_out_type x3))
and copy_out_type_param :
Ast_51.Outcometree.out_type_param -> Ast_500.Outcometree.out_type_param =
fun x ->
let (x0, x1) = x in
(x0, (let (x0, x1) = x1 in ((copy_variance x0), (copy_injectivity x1))))
and copy_injectivity :
Ast_51.Asttypes.injectivity -> Ast_500.Asttypes.injectivity =
function
| Ast_51.Asttypes.Injective -> Ast_500.Asttypes.Injective
| Ast_51.Asttypes.NoInjectivity -> Ast_500.Asttypes.NoInjectivity
and copy_variance : Ast_51.Asttypes.variance -> Ast_500.Asttypes.variance =
function
| Ast_51.Asttypes.Covariant -> Ast_500.Asttypes.Covariant
| Ast_51.Asttypes.Contravariant -> Ast_500.Asttypes.Contravariant
| Ast_51.Asttypes.NoVariance -> Ast_500.Asttypes.NoVariance
and copy_out_type :
Ast_51.Outcometree.out_type -> Ast_500.Outcometree.out_type =
function
| Ast_51.Outcometree.Otyp_abstract -> Ast_500.Outcometree.Otyp_abstract
| Ast_51.Outcometree.Otyp_open -> Ast_500.Outcometree.Otyp_open
| Ast_51.Outcometree.Otyp_alias {non_gen = _; aliased=x0; alias=x1} ->
Ast_500.Outcometree.Otyp_alias ((copy_out_type x0), x1)
| Ast_51.Outcometree.Otyp_arrow (x0, x1, x2) ->
Ast_500.Outcometree.Otyp_arrow
(x0, (copy_out_type x1), (copy_out_type x2))
| Ast_51.Outcometree.Otyp_class (x0, x1) ->
Ast_500.Outcometree.Otyp_class
(false, (copy_out_ident x0), (List.map copy_out_type x1))
| Ast_51.Outcometree.Otyp_constr (x0, x1) ->
Ast_500.Outcometree.Otyp_constr
((copy_out_ident x0), (List.map copy_out_type x1))
| Ast_51.Outcometree.Otyp_manifest (x0, x1) ->
Ast_500.Outcometree.Otyp_manifest
((copy_out_type x0), (copy_out_type x1))
| Ast_51.Outcometree.Otyp_object {fields=x0; open_row=x1} ->
Ast_500.Outcometree.Otyp_object
((List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1)))
x0), Some x1)
| Ast_51.Outcometree.Otyp_record x0 ->
Ast_500.Outcometree.Otyp_record
(List.map
(fun x -> let (x0, x1, x2) = x in (x0, x1, (copy_out_type x2))) x0)
| Ast_51.Outcometree.Otyp_stuff x0 -> Ast_500.Outcometree.Otyp_stuff x0
| Ast_51.Outcometree.Otyp_sum x0 ->
Ast_500.Outcometree.Otyp_sum (List.map copy_out_constructor x0)
| Ast_51.Outcometree.Otyp_tuple x0 ->
Ast_500.Outcometree.Otyp_tuple (List.map copy_out_type x0)
| Ast_51.Outcometree.Otyp_var (x0, x1) ->
Ast_500.Outcometree.Otyp_var (x0, x1)
| Ast_51.Outcometree.Otyp_variant (x0, x1, x2) ->
Ast_500.Outcometree.Otyp_variant
(false, (copy_out_variant x0), x1,
(Option.map (fun x -> List.map (fun x -> x) x) x2))
| Ast_51.Outcometree.Otyp_poly (x0, x1) ->
Ast_500.Outcometree.Otyp_poly
((List.map (fun x -> x) x0), (copy_out_type x1))
| Ast_51.Outcometree.Otyp_module (x0, x1) ->
Ast_500.Outcometree.Otyp_module
((copy_out_ident x0),
(List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1)))
x1))
| Ast_51.Outcometree.Otyp_attribute (x0, x1) ->
Ast_500.Outcometree.Otyp_attribute
((copy_out_type x0), (copy_out_attribute x1))
and copy_out_attribute :
Ast_51.Outcometree.out_attribute -> Ast_500.Outcometree.out_attribute =
fun { Ast_51.Outcometree.oattr_name = oattr_name } ->
{ Ast_500.Outcometree.oattr_name = oattr_name }
and copy_out_variant :
Ast_51.Outcometree.out_variant -> Ast_500.Outcometree.out_variant =
function
| Ast_51.Outcometree.Ovar_fields x0 ->
Ast_500.Outcometree.Ovar_fields
(List.map
(fun x ->
let (x0, x1, x2) = x in (x0, x1, (List.map copy_out_type x2)))
x0)
| Ast_51.Outcometree.Ovar_typ x0 ->
Ast_500.Outcometree.Ovar_typ (copy_out_type x0)
and copy_out_constructor :
Ast_51.Outcometree.out_constructor -> Ast_500.Outcometree.out_constructor =
fun
{ Ast_51.Outcometree.ocstr_name = ocstr_name;
Ast_51.Outcometree.ocstr_args = ocstr_args;
Ast_51.Outcometree.ocstr_return_type = ocstr_return_type }
->
{
Ast_500.Outcometree.ocstr_name = ocstr_name;
Ast_500.Outcometree.ocstr_args = (List.map copy_out_type ocstr_args);
Ast_500.Outcometree.ocstr_return_type =
(Option.map copy_out_type ocstr_return_type)
}
and copy_out_value :
Ast_51.Outcometree.out_value -> Ast_500.Outcometree.out_value =
function
| Ast_51.Outcometree.Oval_array x0 ->
Ast_500.Outcometree.Oval_array (List.map copy_out_value x0)
| Ast_51.Outcometree.Oval_char x0 -> Ast_500.Outcometree.Oval_char x0
| Ast_51.Outcometree.Oval_constr (x0, x1) ->
Ast_500.Outcometree.Oval_constr
((copy_out_ident x0), (List.map copy_out_value x1))
| Ast_51.Outcometree.Oval_ellipsis -> Ast_500.Outcometree.Oval_ellipsis
| Ast_51.Outcometree.Oval_float x0 -> Ast_500.Outcometree.Oval_float x0
| Ast_51.Outcometree.Oval_int x0 -> Ast_500.Outcometree.Oval_int x0
| Ast_51.Outcometree.Oval_int32 x0 -> Ast_500.Outcometree.Oval_int32 x0
| Ast_51.Outcometree.Oval_int64 x0 -> Ast_500.Outcometree.Oval_int64 x0
| Ast_51.Outcometree.Oval_nativeint x0 ->
Ast_500.Outcometree.Oval_nativeint x0
| Ast_51.Outcometree.Oval_list x0 ->
Ast_500.Outcometree.Oval_list (List.map copy_out_value x0)
| Ast_51.Outcometree.Oval_printer x0 -> Ast_500.Outcometree.Oval_printer x0
| Ast_51.Outcometree.Oval_record x0 ->
Ast_500.Outcometree.Oval_record
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_ident x0), (copy_out_value x1)))
x0)
| Ast_51.Outcometree.Oval_string (x0, x1, x2) ->
Ast_500.Outcometree.Oval_string (x0, x1, (copy_out_string x2))
| Ast_51.Outcometree.Oval_stuff x0 -> Ast_500.Outcometree.Oval_stuff x0
| Ast_51.Outcometree.Oval_tuple x0 ->
Ast_500.Outcometree.Oval_tuple (List.map copy_out_value x0)
| Ast_51.Outcometree.Oval_variant (x0, x1) ->
Ast_500.Outcometree.Oval_variant (x0, (Option.map copy_out_value x1))
and copy_out_string :
Ast_51.Outcometree.out_string -> Ast_500.Outcometree.out_string =
function
| Ast_51.Outcometree.Ostr_string -> Ast_500.Outcometree.Ostr_string
| Ast_51.Outcometree.Ostr_bytes -> Ast_500.Outcometree.Ostr_bytes
and copy_out_ident :
Ast_51.Outcometree.out_ident -> Ast_500.Outcometree.out_ident =
function
| Ast_51.Outcometree.Oide_apply (x0, x1) ->
Ast_500.Outcometree.Oide_apply
((copy_out_ident x0), (copy_out_ident x1))
| Ast_51.Outcometree.Oide_dot (x0, x1) ->
Ast_500.Outcometree.Oide_dot ((copy_out_ident x0), x1)
| Ast_51.Outcometree.Oide_ident x0 ->
Ast_500.Outcometree.Oide_ident (copy_out_name x0)
and copy_out_name :
Ast_51.Outcometree.out_name -> Ast_500.Outcometree.out_name =
fun { Ast_51.Outcometree.printed_name = printed_name } ->
{ Ast_500.Outcometree.printed_name = printed_name }
================================================
FILE: src/vendored-omp/src/migrate_parsetree_51_52.ml
================================================
include Migrate_parsetree_51_52_migrate
================================================
FILE: src/vendored-omp/src/migrate_parsetree_51_52_migrate.ml
================================================
open Stdlib0
module From = Ast_51
module To = Ast_52
let get_label lbl =
if lbl = "" then Ast_52.Asttypes.Nolabel
else if String.get lbl 0 = '?' then
Optional (String.sub lbl 1 @@ String.length lbl - 1)
else Labelled lbl
let rec copy_out_type_extension :
Ast_51.Outcometree.out_type_extension ->
Ast_52.Outcometree.out_type_extension
=
fun
{ Ast_51.Outcometree.otyext_name = otyext_name;
Ast_51.Outcometree.otyext_params = otyext_params;
Ast_51.Outcometree.otyext_constructors = otyext_constructors;
Ast_51.Outcometree.otyext_private = otyext_private }
->
{
Ast_52.Outcometree.otyext_name = otyext_name;
Ast_52.Outcometree.otyext_params =
(List.map (fun x -> x) otyext_params);
Ast_52.Outcometree.otyext_constructors =
(List.map copy_out_constructor otyext_constructors);
Ast_52.Outcometree.otyext_private = (copy_private_flag otyext_private)
}
and copy_out_phrase :
Ast_51.Outcometree.out_phrase -> Ast_52.Outcometree.out_phrase =
function
| Ast_51.Outcometree.Ophr_eval (x0, x1) ->
Ast_52.Outcometree.Ophr_eval ((copy_out_value x0), (copy_out_type x1))
| Ast_51.Outcometree.Ophr_signature x0 ->
Ast_52.Outcometree.Ophr_signature
(List.map
(fun x ->
let (x0, x1) = x in
((copy_out_sig_item x0), (Option.map copy_out_value x1))) x0)
| Ast_51.Outcometree.Ophr_exception x0 ->
Ast_52.Outcometree.Ophr_exception
(let (x0, x1) = x0 in (x0, (copy_out_value x1)))
and copy_out_sig_item :
Ast_51.Outcometree.out_sig_item -> Ast_52.Outcometree.out_sig_item =
function
| Ast_51.Outcometree.Osig_class (x0, x1, x2, x3, x4) ->
Ast_52.Outcometree.Osig_class
(x0, x1, (List.map copy_out_type_param x2), (copy_out_class_type x3),
(copy_out_rec_status x4))
| Ast_51.Outcometree.Osig_class_type (x0, x1, x2, x3, x4) ->
Ast_52.Outcometree.Osig_class_type
(x0, x1, (List.map copy_out_type_param x2), (copy_out_class_type x3),
(copy_out_rec_status x4))
| Ast_51.Outcometree.Osig_typext (x0, x1) ->
Ast_52.Outcometree.Osig_typext
((copy_out_extension_constructor x0), (copy_out_ext_status x1))
| Ast_51.Outcometree.Osig_modtype (x0, x1) ->
Ast_52.Outcometree.Osig_modtype (x0, (copy_out_module_type x1))
| Ast_51.Outcometree.Osig_module (x0, x1, x2) ->
Ast_52.Outcometree.Osig_module
(x0, (copy_out_module_type x1), (copy_out_rec_status x2))
| Ast_51.Outcometree.Osig_type (x0, x1) ->
Ast_52.Outcometree.Osig_type
((copy_out_type_decl x0), (copy_out_rec_status x1))
| Ast_51.Outcometree.Osig_value x0 ->
Ast_52.Outcometree.Osig_value (copy_out_val_decl x0)
| Ast_51.Outcometree.Osig_ellipsis -> Ast_52.Outcometree.Osig_ellipsis
and copy_out_val_decl :
Ast_51.Outcometree.out_val_decl -> Ast_52.Outcometree.out_val_decl =
fun
{ Ast_51.Outcometree.oval_name = oval_name;
Ast_51.Outcometree.oval_type = oval_type;
Ast_51.Outcometree.oval_prims = oval_prims;
Ast_51.Outcometree.oval_attributes = oval_attributes }
->
{
Ast_52.Outcometree.oval_name = oval_name;
Ast_52.Outcometree.oval_type = (copy_out_type oval_type);
Ast_52.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims);
Ast_52.Outcometree.oval_attributes =
(List.map copy_out_attribute oval_attributes)
}
and copy_out_type_decl :
Ast_51.Outcometree.out_type_decl -> Ast_52.Outcometree.out_type_decl =
fun
{ Ast_51.Outcometree.otype_name = otype_name;
Ast_51.Outcometree.otype_params = otype_params;
Ast_51.Outcometree.otype_type = otype_type;
Ast_51.Outcometree.otype_private = otype_private;
Ast_51.Outcometree.otype_immediate = otype_immediate;
Ast_51.Outcometree.otype_unboxed = otype_unboxed;
Ast_51.Outcometree.otype_cstrs = otype_cstrs }
->
{
Ast_52.Outcometree.otype_name = otype_name;
Ast_52.Outcometree.otype_params =
(List.map copy_out_type_param otype_params);
Ast_52.Outcometree.otype_type = (copy_out_type otype_type);
Ast_52.Outcometree.otype_private = (copy_private_flag otype_private);
Ast_52.Outcometree.otype_immediate =
(copy_Type_immediacy_t otype_immediate);
Ast_52.Outcometree.otype_unboxed = otype_unboxed;
Ast_52.Outcometree.otype_cstrs =
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_type x0), (copy_out_type x1)))
otype_cstrs)
}
and copy_Type_immediacy_t :
Ast_51.Type_immediacy.t -> Ast_52.Type_immediacy.t =
function
| Ast_51.Type_immediacy.Unknown -> Ast_52.Type_immediacy.Unknown
| Ast_51.Type_immediacy.Always -> Ast_52.Type_immediacy.Always
| Ast_51.Type_immediacy.Always_on_64bits ->
Ast_52.Type_immediacy.Always_on_64bits
and copy_out_module_type :
Ast_51.Outcometree.out_module_type -> Ast_52.Outcometree.out_module_type =
function
| Ast_51.Outcometree.Omty_abstract -> Ast_52.Outcometree.Omty_abstract
| Ast_51.Outcometree.Omty_functor (x0, x1) ->
Ast_52.Outcometree.Omty_functor
((Option.map
(fun x ->
let (x0, x1) = x in
((Option.map (fun x -> x) x0), (copy_out_module_type x1))) x0),
(copy_out_module_type x1))
| Ast_51.Outcometree.Omty_ident x0 ->
Ast_52.Outcometree.Omty_ident (copy_out_ident x0)
| Ast_51.Outcometree.Omty_signature x0 ->
Ast_52.Outcometree.Omty_signature (List.map copy_out_sig_item x0)
| Ast_51.Outcometree.Omty_alias x0 ->
Ast_52.Outcometree.Omty_alias (copy_out_ident x0)
and copy_out_ext_status :
Ast_51.Outcometree.out_ext_status -> Ast_52.Outcometree.out_ext_status =
function
| Ast_51.Outcometree.Oext_first -> Ast_52.Outcometree.Oext_first
| Ast_51.Outcometree.Oext_next -> Ast_52.Outcometree.Oext_next
| Ast_51.Outcometree.Oext_exception -> Ast_52.Outcometree.Oext_exception
and copy_out_extension_constructor :
Ast_51.Outcometree.out_extension_constructor ->
Ast_52.Outcometree.out_extension_constructor
=
fun
{ Ast_51.Outcometree.oext_name = oext_name;
Ast_51.Outcometree.oext_type_name = oext_type_name;
Ast_51.Outcometree.oext_type_params = oext_type_params;
Ast_51.Outcometree.oext_args = oext_args;
Ast_51.Outcometree.oext_ret_type = oext_ret_type;
Ast_51.Outcometree.oext_private = oext_private }
->
{
Ast_52.Outcometree.oext_name = oext_name;
Ast_52.Outcometree.oext_type_name = oext_type_name;
Ast_52.Outcometree.oext_type_params =
(List.map (fun x -> x) oext_type_params);
Ast_52.Outcometree.oext_args = (List.map copy_out_type oext_args);
Ast_52.Outcometree.oext_ret_type =
(Option.map copy_out_type oext_ret_type);
Ast_52.Outcometree.oext_private = (copy_private_flag oext_private)
}
and copy_private_flag :
Ast_51.Asttypes.private_flag -> Ast_52.Asttypes.private_flag =
function
| Ast_51.Asttypes.Private -> Ast_52.Asttypes.Private
| Ast_51.Asttypes.Public -> Ast_52.Asttypes.Public
and copy_out_rec_status :
Ast_51.Outcometree.out_rec_status -> Ast_52.Outcometree.out_rec_status =
function
| Ast_51.Outcometree.Orec_not -> Ast_52.Outcometree.Orec_not
| Ast_51.Outcometree.Orec_first -> Ast_52.Outcometree.Orec_first
| Ast_51.Outcometree.Orec_next -> Ast_52.Outcometree.Orec_next
and copy_out_class_type :
Ast_51.Outcometree.out_class_type -> Ast_52.Outcometree.out_class_type =
function
| Ast_51.Outcometree.Octy_constr (x0, x1) ->
Ast_52.Outcometree.Octy_constr
((copy_out_ident x0), (List.map copy_out_type x1))
| Ast_51.Outcometree.Octy_arrow (x0, x1, x2) ->
Ast_52.Outcometree.Octy_arrow
(get_label x0, (copy_out_type x1), (copy_out_class_type x2))
| Ast_51.Outcometree.Octy_signature (x0, x1) ->
Ast_52.Outcometree.Octy_signature
((Option.map copy_out_type x0),
(List.map copy_out_class_sig_item x1))
and copy_out_class_sig_item :
Ast_51.Outcometree.out_class_sig_item ->
Ast_52.Outcometree.out_class_sig_item
=
function
| Ast_51.Outcometree.Ocsg_constraint (x0, x1) ->
Ast_52.Outcometree.Ocsg_constraint
((copy_out_type x0), (copy_out_type x1))
| Ast_51.Outcometree.Ocsg_method (x0, x1, x2, x3) ->
Ast_52.Outcometree.Ocsg_method (x0, x1, x2, (copy_out_type x3))
| Ast_51.Outcometree.Ocsg_value (x0, x1, x2, x3) ->
Ast_52.Outcometree.Ocsg_value (x0, x1, x2, (copy_out_type x3))
and copy_out_type_param :
Ast_51.Outcometree.out_type_param -> Ast_52.Outcometree.out_type_param =
fun x ->
let (x0, x1) = x in
{
ot_non_gen = true;
ot_name= x0;
ot_variance =
let (x0, x1) = x1
in ((copy_variance x0), (copy_injectivity x1));
}
and copy_injectivity :
Ast_51.Asttypes.injectivity -> Ast_52.Asttypes.injectivity =
function
| Ast_51.Asttypes.Injective -> Ast_52.Asttypes.Injective
| Ast_51.Asttypes.NoInjectivity -> Ast_52.Asttypes.NoInjectivity
and copy_variance : Ast_51.Asttypes.variance -> Ast_52.Asttypes.variance =
function
| Ast_51.Asttypes.Covariant -> Ast_52.Asttypes.Covariant
| Ast_51.Asttypes.Contravariant -> Ast_52.Asttypes.Contravariant
| Ast_51.Asttypes.NoVariance -> Ast_52.Asttypes.NoVariance
and copy_out_type :
Ast_51.Outcometree.out_type -> Ast_52.Outcometree.out_type =
function
| Ast_51.Outcometree.Otyp_abstract -> Ast_52.Outcometree.Otyp_abstract
| Otyp_alias {non_gen; aliased; alias} ->
Ast_52.Outcometree.Otyp_alias {non_gen;aliased=(copy_out_type aliased);alias}
| Ast_51.Outcometree.Otyp_open -> Ast_52.Outcometree.Otyp_open
| Ast_51.Outcometree.Otyp_arrow (x0, x1, x2) ->
Ast_52.Outcometree.Otyp_arrow
(get_label x0, (copy_out_type x1), (copy_out_type x2))
| Ast_51.Outcometree.Otyp_class (x0, x1) ->
Ast_52.Outcometree.Otyp_class
((copy_out_ident x0), (List.map copy_out_type x1))
| Ast_51.Outcometree.Otyp_constr (x0, x1) ->
Ast_52.Outcometree.Otyp_constr
((copy_out_ident x0), (List.map copy_out_type x1))
| Ast_51.Outcometree.Otyp_object { fields; open_row} ->
Ast_52.Outcometree.Otyp_object
{fields=(List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1))) fields);
open_row}
| Ast_51.Outcometree.Otyp_manifest (x0, x1) ->
Ast_52.Outcometree.Otyp_manifest
((copy_out_type x0), (copy_out_type x1))
| Ast_51.Outcometree.Otyp_record x0 ->
Ast_52.Outcometree.Otyp_record
(List.map
(fun x -> let (x0, x1, x2) = x in (x0, x1, (copy_out_type x2))) x0)
| Ast_51.Outcometree.Otyp_stuff x0 -> Ast_52.Outcometree.Otyp_stuff x0
| Ast_51.Outcometree.Otyp_sum x0 ->
Ast_52.Outcometree.Otyp_sum (List.map copy_out_constructor x0)
| Ast_51.Outcometree.Otyp_tuple x0 ->
Ast_52.Outcometree.Otyp_tuple (List.map copy_out_type x0)
| Ast_51.Outcometree.Otyp_var (x0, x1) ->
Ast_52.Outcometree.Otyp_var (x0, x1)
| Ast_51.Outcometree.Otyp_variant (x0, x1, x2) ->
Ast_52.Outcometree.Otyp_variant
((copy_out_variant x0), x1,
(Option.map (fun x -> List.map (fun x -> x) x) x2))
| Ast_51.Outcometree.Otyp_poly (x0, x1) ->
Ast_52.Outcometree.Otyp_poly
((List.map (fun x -> x) x0), (copy_out_type x1))
| Ast_51.Outcometree.Otyp_module (x0, x1) ->
Ast_52.Outcometree.Otyp_module
((copy_out_ident x0),
(List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1)))
x1))
| Ast_51.Outcometree.Otyp_attribute (x0, x1) ->
Ast_52.Outcometree.Otyp_attribute
((copy_out_type x0), (copy_out_attribute x1))
and copy_out_attribute :
Ast_51.Outcometree.out_attribute -> Ast_52.Outcometree.out_attribute =
fun { Ast_51.Outcometree.oattr_name = oattr_name } ->
{ Ast_52.Outcometree.oattr_name = oattr_name }
and copy_out_variant :
Ast_51.Outcometree.out_variant -> Ast_52.Outcometree.out_variant =
function
| Ast_51.Outcometree.Ovar_fields x0 ->
Ast_52.Outcometree.Ovar_fields
(List.map
(fun x ->
let (x0, x1, x2) = x in (x0, x1, (List.map copy_out_type x2)))
x0)
| Ast_51.Outcometree.Ovar_typ x0 ->
Ast_52.Outcometree.Ovar_typ (copy_out_type x0)
and copy_out_constructor :
Ast_51.Outcometree.out_constructor -> Ast_52.Outcometree.out_constructor =
fun
{ Ast_51.Outcometree.ocstr_name = ocstr_name;
Ast_51.Outcometree.ocstr_args = ocstr_args;
Ast_51.Outcometree.ocstr_return_type = ocstr_return_type }
->
{
Ast_52.Outcometree.ocstr_name = ocstr_name;
Ast_52.Outcometree.ocstr_args = (List.map copy_out_type ocstr_args);
Ast_52.Outcometree.ocstr_return_type =
(Option.map copy_out_type ocstr_return_type)
}
and copy_out_value :
Ast_51.Outcometree.out_value -> Ast_52.Outcometree.out_value =
function
| Ast_51.Outcometree.Oval_array x0 ->
Ast_52.Outcometree.Oval_array (List.map copy_out_value x0)
| Ast_51.Outcometree.Oval_char x0 -> Ast_52.Outcometree.Oval_char x0
| Ast_51.Outcometree.Oval_constr (x0, x1) ->
Ast_52.Outcometree.Oval_constr
((copy_out_ident x0), (List.map copy_out_value x1))
| Ast_51.Outcometree.Oval_ellipsis -> Ast_52.Outcometree.Oval_ellipsis
| Ast_51.Outcometree.Oval_float x0 -> Ast_52.Outcometree.Oval_float x0
| Ast_51.Outcometree.Oval_int x0 -> Ast_52.Outcometree.Oval_int x0
| Ast_51.Outcometree.Oval_int32 x0 -> Ast_52.Outcometree.Oval_int32 x0
| Ast_51.Outcometree.Oval_int64 x0 -> Ast_52.Outcometree.Oval_int64 x0
| Ast_51.Outcometree.Oval_nativeint x0 ->
Ast_52.Outcometree.Oval_nativeint x0
| Ast_51.Outcometree.Oval_list x0 ->
Ast_52.Outcometree.Oval_list (List.map copy_out_value x0)
| Ast_51.Outcometree.Oval_printer x0 -> Ast_52.Outcometree.Oval_printer x0
| Ast_51.Outcometree.Oval_record x0 ->
Ast_52.Outcometree.Oval_record
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_ident x0), (copy_out_value x1)))
x0)
| Ast_51.Outcometree.Oval_string (x0, x1, x2) ->
Ast_52.Outcometree.Oval_string (x0, x1, (copy_out_string x2))
| Ast_51.Outcometree.Oval_stuff x0 -> Ast_52.Outcometree.Oval_stuff x0
| Ast_51.Outcometree.Oval_tuple x0 ->
Ast_52.Outcometree.Oval_tuple (List.map copy_out_value x0)
| Ast_51.Outcometree.Oval_variant (x0, x1) ->
Ast_52.Outcometree.Oval_variant (x0, (Option.map copy_out_value x1))
and copy_out_string :
Ast_51.Outcometree.out_string -> Ast_52.Outcometree.out_string =
function
| Ast_51.Outcometree.Ostr_string -> Ast_52.Outcometree.Ostr_string
| Ast_51.Outcometree.Ostr_bytes -> Ast_52.Outcometree.Ostr_bytes
and copy_out_ident :
Ast_51.Outcometree.out_ident -> Ast_52.Outcometree.out_ident =
function
| Ast_51.Outcometree.Oide_apply (x0, x1) ->
Ast_52.Outcometree.Oide_apply
((copy_out_ident x0), (copy_out_ident x1))
| Ast_51.Outcometree.Oide_dot (x0, x1) ->
Ast_52.Outcometree.Oide_dot ((copy_out_ident x0), x1)
| Ast_51.Outcometree.Oide_ident x0 ->
Ast_52.Outcometree.Oide_ident (copy_out_name x0)
and copy_out_name :
Ast_51.Outcometree.out_name -> Ast_52.Outcometree.out_name =
fun { Ast_51.Outcometree.printed_name = printed_name } ->
{ Ast_52.Outcometree.printed_name = printed_name }
================================================
FILE: src/vendored-omp/src/migrate_parsetree_52_51.ml
================================================
include Migrate_parsetree_52_51_migrate
================================================
FILE: src/vendored-omp/src/migrate_parsetree_52_51_migrate.ml
================================================
open Stdlib0
module From = Ast_52
module To = Ast_51
let rec copy_out_type_extension :
Ast_52.Outcometree.out_type_extension ->
Ast_51.Outcometree.out_type_extension
=
fun
{ Ast_52.Outcometree.otyext_name = otyext_name;
Ast_52.Outcometree.otyext_params = otyext_params;
Ast_52.Outcometree.otyext_constructors = otyext_constructors;
Ast_52.Outcometree.otyext_private = otyext_private }
->
{
Ast_51.Outcometree.otyext_name = otyext_name;
Ast_51.Outcometree.otyext_params =
(List.map (fun x -> x) otyext_params);
Ast_51.Outcometree.otyext_constructors =
(List.map copy_out_constructor otyext_constructors);
Ast_51.Outcometree.otyext_private = (copy_private_flag otyext_private)
}
and copy_out_phrase :
Ast_52.Outcometree.out_phrase -> Ast_51.Outcometree.out_phrase =
function
| Ast_52.Outcometree.Ophr_eval (x0, x1) ->
Ast_51.Outcometree.Ophr_eval ((copy_out_value x0), (copy_out_type x1))
| Ast_52.Outcometree.Ophr_signature x0 ->
Ast_51.Outcometree.Ophr_signature
(List.map
(fun x ->
let (x0, x1) = x in
((copy_out_sig_item x0), (Option.map copy_out_value x1))) x0)
| Ast_52.Outcometree.Ophr_exception x0 ->
Ast_51.Outcometree.Ophr_exception
(let (x0, x1) = x0 in (x0, (copy_out_value x1)))
and copy_out_sig_item :
Ast_52.Outcometree.out_sig_item -> Ast_51.Outcometree.out_sig_item =
function
| Ast_52.Outcometree.Osig_class (x0, x1, x2, x3, x4) ->
Ast_51.Outcometree.Osig_class
(x0, x1, (List.map copy_out_type_param x2), (copy_out_class_type x3),
(copy_out_rec_status x4))
| Ast_52.Outcometree.Osig_class_type (x0, x1, x2, x3, x4) ->
Ast_51.Outcometree.Osig_class_type
(x0, x1, (List.map copy_out_type_param x2), (copy_out_class_type x3),
(copy_out_rec_status x4))
| Ast_52.Outcometree.Osig_typext (x0, x1) ->
Ast_51.Outcometree.Osig_typext
((copy_out_extension_constructor x0), (copy_out_ext_status x1))
| Ast_52.Outcometree.Osig_modtype (x0, x1) ->
Ast_51.Outcometree.Osig_modtype (x0, (copy_out_module_type x1))
| Ast_52.Outcometree.Osig_module (x0, x1, x2) ->
Ast_51.Outcometree.Osig_module
(x0, (copy_out_module_type x1), (copy_out_rec_status x2))
| Ast_52.Outcometree.Osig_type (x0, x1) ->
Ast_51.Outcometree.Osig_type
((copy_out_type_decl x0), (copy_out_rec_status x1))
| Ast_52.Outcometree.Osig_value x0 ->
Ast_51.Outcometree.Osig_value (copy_out_val_decl x0)
| Ast_52.Outcometree.Osig_ellipsis -> Ast_51.Outcometree.Osig_ellipsis
and copy_out_val_decl :
Ast_52.Outcometree.out_val_decl -> Ast_51.Outcometree.out_val_decl =
fun
{ Ast_52.Outcometree.oval_name = oval_name;
Ast_52.Outcometree.oval_type = oval_type;
Ast_52.Outcometree.oval_prims = oval_prims;
Ast_52.Outcometree.oval_attributes = oval_attributes }
->
{
Ast_51.Outcometree.oval_name = oval_name;
Ast_51.Outcometree.oval_type = (copy_out_type oval_type);
Ast_51.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims);
Ast_51.Outcometree.oval_attributes =
(List.map copy_out_attribute oval_attributes)
}
and copy_out_type_decl :
Ast_52.Outcometree.out_type_decl -> Ast_51.Outcometree.out_type_decl =
fun
{ Ast_52.Outcometree.otype_name = otype_name;
Ast_52.Outcometree.otype_params = otype_params;
Ast_52.Outcometree.otype_type = otype_type;
Ast_52.Outcometree.otype_private = otype_private;
Ast_52.Outcometree.otype_immediate = otype_immediate;
Ast_52.Outcometree.otype_unboxed = otype_unboxed;
Ast_52.Outcometree.otype_cstrs = otype_cstrs }
->
{
Ast_51.Outcometree.otype_name = otype_name;
Ast_51.Outcometree.otype_params =
(List.map copy_out_type_param otype_params);
Ast_51.Outcometree.otype_type = (copy_out_type otype_type);
Ast_51.Outcometree.otype_private = (copy_private_flag otype_private);
Ast_51.Outcometree.otype_immediate =
(copy_Type_immediacy_t otype_immediate);
Ast_51.Outcometree.otype_unboxed = otype_unboxed;
Ast_51.Outcometree.otype_cstrs =
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_type x0), (copy_out_type x1)))
otype_cstrs)
}
and copy_Type_immediacy_t :
Ast_52.Type_immediacy.t -> Ast_51.Type_immediacy.t =
function
| Ast_52.Type_immediacy.Unknown -> Ast_51.Type_immediacy.Unknown
| Ast_52.Type_immediacy.Always -> Ast_51.Type_immediacy.Always
| Ast_52.Type_immediacy.Always_on_64bits ->
Ast_51.Type_immediacy.Always_on_64bits
and copy_out_module_type :
Ast_52.Outcometree.out_module_type -> Ast_51.Outcometree.out_module_type =
function
| Ast_52.Outcometree.Omty_abstract -> Ast_51.Outcometree.Omty_abstract
| Ast_52.Outcometree.Omty_functor (x0, x1) ->
Ast_51.Outcometree.Omty_functor
((Option.map
(fun x ->
let (x0, x1) = x in
((Option.map (fun x -> x) x0), (copy_out_module_type x1))) x0),
(copy_out_module_type x1))
| Ast_52.Outcometree.Omty_ident x0 ->
Ast_51.Outcometree.Omty_ident (copy_out_ident x0)
| Ast_52.Outcometree.Omty_signature x0 ->
Ast_51.Outcometree.Omty_signature (List.map copy_out_sig_item x0)
| Ast_52.Outcometree.Omty_alias x0 ->
Ast_51.Outcometree.Omty_alias (copy_out_ident x0)
and copy_out_ext_status :
Ast_52.Outcometree.out_ext_status -> Ast_51.Outcometree.out_ext_status =
function
| Ast_52.Outcometree.Oext_first -> Ast_51.Outcometree.Oext_first
| Ast_52.Outcometree.Oext_next -> Ast_51.Outcometree.Oext_next
| Ast_52.Outcometree.Oext_exception -> Ast_51.Outcometree.Oext_exception
and copy_out_extension_constructor :
Ast_52.Outcometree.out_extension_constructor ->
Ast_51.Outcometree.out_extension_constructor
=
fun
{ Ast_52.Outcometree.oext_name = oext_name;
Ast_52.Outcometree.oext_type_name = oext_type_name;
Ast_52.Outcometree.oext_type_params = oext_type_params;
Ast_52.Outcometree.oext_args = oext_args;
Ast_52.Outcometree.oext_ret_type = oext_ret_type;
Ast_52.Outcometree.oext_private = oext_private }
->
{
Ast_51.Outcometree.oext_name = oext_name;
Ast_51.Outcometree.oext_type_name = oext_type_name;
Ast_51.Outcometree.oext_type_params =
(List.map (fun x -> x) oext_type_params);
Ast_51.Outcometree.oext_args = (List.map copy_out_type oext_args);
Ast_51.Outcometree.oext_ret_type =
(Option.map copy_out_type oext_ret_type);
Ast_51.Outcometree.oext_private = (copy_private_flag oext_private)
}
and copy_private_flag :
Ast_52.Asttypes.private_flag -> Ast_51.Asttypes.private_flag =
function
| Ast_52.Asttypes.Private -> Ast_51.Asttypes.Private
| Ast_52.Asttypes.Public -> Ast_51.Asttypes.Public
and copy_out_rec_status :
Ast_52.Outcometree.out_rec_status -> Ast_51.Outcometree.out_rec_status =
function
| Ast_52.Outcometree.Orec_not -> Ast_51.Outcometree.Orec_not
| Ast_52.Outcometree.Orec_first -> Ast_51.Outcometree.Orec_first
| Ast_52.Outcometree.Orec_next -> Ast_51.Outcometree.Orec_next
and copy_out_class_type :
Ast_52.Outcometree.out_class_type -> Ast_51.Outcometree.out_class_type =
function
| Ast_52.Outcometree.Octy_constr (x0, x1) ->
Ast_51.Outcometree.Octy_constr
((copy_out_ident x0), (List.map copy_out_type x1))
| Ast_52.Outcometree.Octy_arrow (x0, x1, x2) ->
Ast_51.Outcometree.Octy_arrow
((match x0 with Nolabel -> "" | Labelled s -> s | Optional s -> "?" ^ s), (copy_out_type x1), (copy_out_class_type x2))
| Ast_52.Outcometree.Octy_signature (x0, x1) ->
Ast_51.Outcometree.Octy_signature
((Option.map copy_out_type x0),
(List.map copy_out_class_sig_item x1))
and copy_out_class_sig_item :
Ast_52.Outcometree.out_class_sig_item ->
Ast_51.Outcometree.out_class_sig_item
=
function
| Ast_52.Outcometree.Ocsg_constraint (x0, x1) ->
Ast_51.Outcometree.Ocsg_constraint
((copy_out_type x0), (copy_out_type x1))
| Ast_52.Outcometree.Ocsg_method (x0, x1, x2, x3) ->
Ast_51.Outcometree.Ocsg_method (x0, x1, x2, (copy_out_type x3))
| Ast_52.Outcometree.Ocsg_value (x0, x1, x2, x3) ->
Ast_51.Outcometree.Ocsg_value (x0, x1, x2, (copy_out_type x3))
and copy_out_type_param :
Ast_52.Outcometree.out_type_param -> Ast_51.Outcometree.out_type_param =
fun
{ Ast_52.Outcometree.ot_non_gen = _;
Ast_52.Outcometree.ot_name = ot_name;
Ast_52.Outcometree.ot_variance = ot_variance }
->
ot_name,
(let (x0, x1) = ot_variance in
((copy_variance x0), (copy_injectivity x1)))
and copy_injectivity :
Ast_52.Asttypes.injectivity -> Ast_51.Asttypes.injectivity =
function
| Ast_52.Asttypes.Injective -> Ast_51.Asttypes.Injective
| Ast_52.Asttypes.NoInjectivity -> Ast_51.Asttypes.NoInjectivity
and copy_variance : Ast_52.Asttypes.variance -> Ast_51.Asttypes.variance =
function
| Ast_52.Asttypes.Covariant -> Ast_51.Asttypes.Covariant
| Ast_52.Asttypes.Contravariant -> Ast_51.Asttypes.Contravariant
| Ast_52.Asttypes.NoVariance -> Ast_51.Asttypes.NoVariance
and copy_out_type :
Ast_52.Outcometree.out_type -> Ast_51.Outcometree.out_type =
function
| Ast_52.Outcometree.Otyp_abstract -> Ast_51.Outcometree.Otyp_abstract
| Ast_52.Outcometree.Otyp_open -> Ast_51.Outcometree.Otyp_open
| Ast_52.Outcometree.Otyp_alias {non_gen; aliased=x0; alias=x1} ->
Ast_51.Outcometree.Otyp_alias {non_gen; aliased=(copy_out_type x0); alias=x1}
| Ast_52.Outcometree.Otyp_arrow (x0, x1, x2) ->
Ast_51.Outcometree.Otyp_arrow
((match x0 with Nolabel -> "" | Labelled s -> s | Optional s -> "?" ^ s), (copy_out_type x1), (copy_out_type x2))
| Ast_52.Outcometree.Otyp_class (x0, x1) ->
Ast_51.Outcometree.Otyp_class
((copy_out_ident x0), (List.map copy_out_type x1))
| Ast_52.Outcometree.Otyp_constr (x0, x1) ->
Ast_51.Outcometree.Otyp_constr
((copy_out_ident x0), (List.map copy_out_type x1))
| Ast_52.Outcometree.Otyp_manifest (x0, x1) ->
Ast_51.Outcometree.Otyp_manifest
((copy_out_type x0), (copy_out_type x1))
| Ast_52.Outcometree.Otyp_object {fields=x0; open_row=x1} ->
Ast_51.Outcometree.Otyp_object
{ fields = (List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1))) x0);
open_row = x1 }
| Ast_52.Outcometree.Otyp_record x0 ->
Ast_51.Outcometree.Otyp_record
(List.map
(fun x -> let (x0, x1, x2) = x in (x0, x1, (copy_out_type x2))) x0)
| Ast_52.Outcometree.Otyp_stuff x0 -> Ast_51.Outcometree.Otyp_stuff x0
| Ast_52.Outcometree.Otyp_sum x0 ->
Ast_51.Outcometree.Otyp_sum (List.map copy_out_constructor x0)
| Ast_52.Outcometree.Otyp_tuple x0 ->
Ast_51.Outcometree.Otyp_tuple (List.map copy_out_type x0)
| Ast_52.Outcometree.Otyp_var (x0, x1) ->
Ast_51.Outcometree.Otyp_var (x0, x1)
| Ast_52.Outcometree.Otyp_variant (x0, x1, x2) ->
Ast_51.Outcometree.Otyp_variant
((copy_out_variant x0), x1,
(Option.map (fun x -> List.map (fun x -> x) x) x2))
| Ast_52.Outcometree.Otyp_poly (x0, x1) ->
Ast_51.Outcometree.Otyp_poly
((List.map (fun x -> x) x0), (copy_out_type x1))
| Ast_52.Outcometree.Otyp_module (x0, x1) ->
Ast_51.Outcometree.Otyp_module
((copy_out_ident x0),
(List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1)))
x1))
| Ast_52.Outcometree.Otyp_attribute (x0, x1) ->
Ast_51.Outcometree.Otyp_attribute
((copy_out_type x0), (copy_out_attribute x1))
and copy_out_attribute :
Ast_52.Outcometree.out_attribute -> Ast_51.Outcometree.out_attribute =
fun { Ast_52.Outcometree.oattr_name = oattr_name } ->
{ Ast_51.Outcometree.oattr_name = oattr_name }
and copy_out_variant :
Ast_52.Outcometree.out_variant -> Ast_51.Outcometree.out_variant =
function
| Ast_52.Outcometree.Ovar_fields x0 ->
Ast_51.Outcometree.Ovar_fields
(List.map
(fun x ->
let (x0, x1, x2) = x in (x0, x1, (List.map copy_out_type x2)))
x0)
| Ast_52.Outcometree.Ovar_typ x0 ->
Ast_51.Outcometree.Ovar_typ (copy_out_type x0)
and copy_out_constructor :
Ast_52.Outcometree.out_constructor -> Ast_51.Outcometree.out_constructor =
fun
{ Ast_52.Outcometree.ocstr_name = ocstr_name;
Ast_52.Outcometree.ocstr_args = ocstr_args;
Ast_52.Outcometree.ocstr_return_type = ocstr_return_type }
->
{
Ast_51.Outcometree.ocstr_name = ocstr_name;
Ast_51.Outcometree.ocstr_args = (List.map copy_out_type ocstr_args);
Ast_51.Outcometree.ocstr_return_type =
(Option.map copy_out_type ocstr_return_type)
}
and copy_arg_label : Ast_52.Asttypes.arg_label -> Ast_51.Asttypes.arg_label =
function
| Ast_52.Asttypes.Nolabel -> Ast_51.Asttypes.Nolabel
| Ast_52.Asttypes.Labelled x0 -> Ast_51.Asttypes.Labelled x0
| Ast_52.Asttypes.Optional x0 -> Ast_51.Asttypes.Optional x0
and copy_out_value :
Ast_52.Outcometree.out_value -> Ast_51.Outcometree.out_value =
function
| Ast_52.Outcometree.Oval_array x0 ->
Ast_51.Outcometree.Oval_array (List.map copy_out_value x0)
| Ast_52.Outcometree.Oval_char x0 -> Ast_51.Outcometree.Oval_char x0
| Ast_52.Outcometree.Oval_constr (x0, x1) ->
Ast_51.Outcometree.Oval_constr
((copy_out_ident x0), (List.map copy_out_value x1))
| Ast_52.Outcometree.Oval_ellipsis -> Ast_51.Outcometree.Oval_ellipsis
| Ast_52.Outcometree.Oval_float x0 -> Ast_51.Outcometree.Oval_float x0
| Ast_52.Outcometree.Oval_int x0 -> Ast_51.Outcometree.Oval_int x0
| Ast_52.Outcometree.Oval_int32 x0 -> Ast_51.Outcometree.Oval_int32 x0
| Ast_52.Outcometree.Oval_int64 x0 -> Ast_51.Outcometree.Oval_int64 x0
| Ast_52.Outcometree.Oval_nativeint x0 ->
Ast_51.Outcometree.Oval_nativeint x0
| Ast_52.Outcometree.Oval_list x0 ->
Ast_51.Outcometree.Oval_list (List.map copy_out_value x0)
| Ast_52.Outcometree.Oval_printer x0 -> Ast_51.Outcometree.Oval_printer x0
| Ast_52.Outcometree.Oval_record x0 ->
Ast_51.Outcometree.Oval_record
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_ident x0), (copy_out_value x1)))
x0)
| Ast_52.Outcometree.Oval_string (x0, x1, x2) ->
Ast_51.Outcometree.Oval_string (x0, x1, (copy_out_string x2))
| Ast_52.Outcometree.Oval_stuff x0 -> Ast_51.Outcometree.Oval_stuff x0
| Ast_52.Outcometree.Oval_tuple x0 ->
Ast_51.Outcometree.Oval_tuple (List.map copy_out_value x0)
| Ast_52.Outcometree.Oval_variant (x0, x1) ->
Ast_51.Outcometree.Oval_variant (x0, (Option.map copy_out_value x1))
| Ast_52.Outcometree.Oval_lazy x0 ->
Ast_51.Outcometree.Oval_constr (Oide_ident { printed_name = "lazy"}, [copy_out_value x0])
and copy_out_string :
Ast_52.Outcometree.out_string -> Ast_51.Outcometree.out_string =
function
| Ast_52.Outcometree.Ostr_string -> Ast_51.Outcometree.Ostr_string
| Ast_52.Outcometree.Ostr_bytes -> Ast_51.Outcometree.Ostr_bytes
and copy_out_ident :
Ast_52.Outcometree.out_ident -> Ast_51.Outcometree.out_ident =
function
| Ast_52.Outcometree.Oide_apply (x0, x1) ->
Ast_51.Outcometree.Oide_apply
((copy_out_ident x0), (copy_out_ident x1))
| Ast_52.Outcometree.Oide_dot (x0, x1) ->
Ast_51.Outcometree.Oide_dot ((copy_out_ident x0), x1)
| Ast_52.Outcometree.Oide_ident x0 ->
Ast_51.Outcometree.Oide_ident (copy_out_name x0)
and copy_out_name :
Ast_52.Outcometree.out_name -> Ast_51.Outcometree.out_name =
fun { Ast_52.Outcometree.printed_name = printed_name } ->
{ Ast_51.Outcometree.printed_name = printed_name }
================================================
FILE: src/vendored-omp/src/migrate_parsetree_52_53.ml
================================================
include Migrate_parsetree_52_53_migrate
================================================
FILE: src/vendored-omp/src/migrate_parsetree_52_53_migrate.ml
================================================
open Stdlib0
module From = Ast_52
module To = Ast_53
let rec (copy_out_type_extension :
Ast_52.Outcometree.out_type_extension ->
Ast_53.Outcometree.out_type_extension)
=
fun
{ Ast_52.Outcometree.otyext_name = otyext_name;
Ast_52.Outcometree.otyext_params = otyext_params;
Ast_52.Outcometree.otyext_constructors = otyext_constructors;
Ast_52.Outcometree.otyext_private = otyext_private }
->
{
Ast_53.Outcometree.otyext_name = otyext_name;
Ast_53.Outcometree.otyext_params =
(List.map (fun x -> x) otyext_params);
Ast_53.Outcometree.otyext_constructors =
(List.map (fun x -> copy_out_constructor x) otyext_constructors);
Ast_53.Outcometree.otyext_private = (copy_private_flag otyext_private)
}
and (copy_out_phrase :
Ast_52.Outcometree.out_phrase -> Ast_53.Outcometree.out_phrase)
=
function
| Ast_52.Outcometree.Ophr_eval (x0, x1) ->
Ast_53.Outcometree.Ophr_eval ((copy_out_value x0), (copy_out_type x1))
| Ast_52.Outcometree.Ophr_signature x0 ->
Ast_53.Outcometree.Ophr_signature
(List.map
(fun x ->
let (x0, x1) = x in
((copy_out_sig_item x0),
(Option.map (fun x -> copy_out_value x) x1))) x0)
| Ast_52.Outcometree.Ophr_exception x0 ->
Ast_53.Outcometree.Ophr_exception
(let (x0, x1) = x0 in (x0, (copy_out_value x1)))
and (copy_out_sig_item :
Ast_52.Outcometree.out_sig_item -> Ast_53.Outcometree.out_sig_item)
=
function
| Ast_52.Outcometree.Osig_class (x0, x1, x2, x3, x4) ->
Ast_53.Outcometree.Osig_class
(x0, x1, (List.map (fun x -> copy_out_type_param x) x2),
(copy_out_class_type x3), (copy_out_rec_status x4))
| Ast_52.Outcometree.Osig_class_type (x0, x1, x2, x3, x4) ->
Ast_53.Outcometree.Osig_class_type
(x0, x1, (List.map (fun x -> copy_out_type_param x) x2),
(copy_out_class_type x3), (copy_out_rec_status x4))
| Ast_52.Outcometree.Osig_typext (x0, x1) ->
Ast_53.Outcometree.Osig_typext
((copy_out_extension_constructor x0), (copy_out_ext_status x1))
| Ast_52.Outcometree.Osig_modtype (x0, x1) ->
Ast_53.Outcometree.Osig_modtype (x0, (copy_out_module_type x1))
| Ast_52.Outcometree.Osig_module (x0, x1, x2) ->
Ast_53.Outcometree.Osig_module
(x0, (copy_out_module_type x1), (copy_out_rec_status x2))
| Ast_52.Outcometree.Osig_type (x0, x1) ->
Ast_53.Outcometree.Osig_type
((copy_out_type_decl x0), (copy_out_rec_status x1))
| Ast_52.Outcometree.Osig_value x0 ->
Ast_53.Outcometree.Osig_value (copy_out_val_decl x0)
| Ast_52.Outcometree.Osig_ellipsis -> Ast_53.Outcometree.Osig_ellipsis
and (copy_out_val_decl :
Ast_52.Outcometree.out_val_decl -> Ast_53.Outcometree.out_val_decl)
=
fun
{ Ast_52.Outcometree.oval_name = oval_name;
Ast_52.Outcometree.oval_type = oval_type;
Ast_52.Outcometree.oval_prims = oval_prims;
Ast_52.Outcometree.oval_attributes = oval_attributes }
->
{
Ast_53.Outcometree.oval_name = oval_name;
Ast_53.Outcometree.oval_type = (copy_out_type oval_type);
Ast_53.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims);
Ast_53.Outcometree.oval_attributes =
(List.map (fun x -> copy_out_attribute x) oval_attributes)
}
and (copy_out_type_decl :
Ast_52.Outcometree.out_type_decl -> Ast_53.Outcometree.out_type_decl)
=
fun
{ Ast_52.Outcometree.otype_name = otype_name;
Ast_52.Outcometree.otype_params = otype_params;
Ast_52.Outcometree.otype_type = otype_type;
Ast_52.Outcometree.otype_private = otype_private;
Ast_52.Outcometree.otype_immediate = otype_immediate;
Ast_52.Outcometree.otype_unboxed = otype_unboxed;
Ast_52.Outcometree.otype_cstrs = otype_cstrs }
->
{
Ast_53.Outcometree.otype_name = otype_name;
Ast_53.Outcometree.otype_params =
(List.map (fun x -> copy_out_type_param x) otype_params);
Ast_53.Outcometree.otype_type = (copy_out_type otype_type);
Ast_53.Outcometree.otype_private = (copy_private_flag otype_private);
Ast_53.Outcometree.otype_immediate =
(copy_Type_immediacy_t otype_immediate);
Ast_53.Outcometree.otype_unboxed = otype_unboxed;
Ast_53.Outcometree.otype_cstrs =
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_type x0), (copy_out_type x1)))
otype_cstrs)
}
and (copy_Type_immediacy_t :
Ast_52.Type_immediacy.t -> Ast_53.Type_immediacy.t)
=
function
| Ast_52.Type_immediacy.Unknown -> Ast_53.Type_immediacy.Unknown
| Ast_52.Type_immediacy.Always -> Ast_53.Type_immediacy.Always
| Ast_52.Type_immediacy.Always_on_64bits ->
Ast_53.Type_immediacy.Always_on_64bits
and (copy_out_module_type :
Ast_52.Outcometree.out_module_type ->
Ast_53.Outcometree.out_module_type)
=
function
| Ast_52.Outcometree.Omty_abstract -> Ast_53.Outcometree.Omty_abstract
| Ast_52.Outcometree.Omty_functor (x0, x1) ->
Ast_53.Outcometree.Omty_functor
((Option.map
(fun x ->
let (x0, x1) = x in
((Option.map (fun x -> x) x0), (copy_out_module_type x1))) x0),
(copy_out_module_type x1))
| Ast_52.Outcometree.Omty_ident x0 ->
Ast_53.Outcometree.Omty_ident (copy_out_ident x0)
| Ast_52.Outcometree.Omty_signature x0 ->
Ast_53.Outcometree.Omty_signature
(List.map (fun x -> copy_out_sig_item x) x0)
| Ast_52.Outcometree.Omty_alias x0 ->
Ast_53.Outcometree.Omty_alias (copy_out_ident x0)
and (copy_out_ext_status :
Ast_52.Outcometree.out_ext_status -> Ast_53.Outcometree.out_ext_status)
=
function
| Ast_52.Outcometree.Oext_first -> Ast_53.Outcometree.Oext_first
| Ast_52.Outcometree.Oext_next -> Ast_53.Outcometree.Oext_next
| Ast_52.Outcometree.Oext_exception -> Ast_53.Outcometree.Oext_exception
and (copy_out_extension_constructor :
Ast_52.Outcometree.out_extension_constructor ->
Ast_53.Outcometree.out_extension_constructor)
=
fun
{ Ast_52.Outcometree.oext_name = oext_name;
Ast_52.Outcometree.oext_type_name = oext_type_name;
Ast_52.Outcometree.oext_type_params = oext_type_params;
Ast_52.Outcometree.oext_args = oext_args;
Ast_52.Outcometree.oext_ret_type = oext_ret_type;
Ast_52.Outcometree.oext_private = oext_private }
->
{
Ast_53.Outcometree.oext_name = oext_name;
Ast_53.Outcometree.oext_type_name = oext_type_name;
Ast_53.Outcometree.oext_type_params =
(List.map (fun x -> x) oext_type_params);
Ast_53.Outcometree.oext_args =
(List.map (fun x -> copy_out_type x) oext_args);
Ast_53.Outcometree.oext_ret_type =
(Option.map (fun x -> copy_out_type x) oext_ret_type);
Ast_53.Outcometree.oext_private = (copy_private_flag oext_private)
}
and (copy_private_flag :
Ast_52.Asttypes.private_flag -> Ast_53.Asttypes.private_flag)
=
function
| Ast_52.Asttypes.Private -> Ast_53.Asttypes.Private
| Ast_52.Asttypes.Public -> Ast_53.Asttypes.Public
and (copy_out_rec_status :
Ast_52.Outcometree.out_rec_status -> Ast_53.Outcometree.out_rec_status)
=
function
| Ast_52.Outcometree.Orec_not -> Ast_53.Outcometree.Orec_not
| Ast_52.Outcometree.Orec_first -> Ast_53.Outcometree.Orec_first
| Ast_52.Outcometree.Orec_next -> Ast_53.Outcometree.Orec_next
and (copy_out_class_type :
Ast_52.Outcometree.out_class_type -> Ast_53.Outcometree.out_class_type)
=
function
| Ast_52.Outcometree.Octy_constr (x0, x1) ->
Ast_53.Outcometree.Octy_constr
((copy_out_ident x0), (List.map (fun x -> copy_out_type x) x1))
| Ast_52.Outcometree.Octy_arrow (x0, x1, x2) ->
Ast_53.Outcometree.Octy_arrow
((copy_arg_label x0), (copy_out_type x1), (copy_out_class_type x2))
| Ast_52.Outcometree.Octy_signature (x0, x1) ->
Ast_53.Outcometree.Octy_signature
((Option.map (fun x -> copy_out_type x) x0),
(List.map (fun x -> copy_out_class_sig_item x) x1))
and (copy_out_class_sig_item :
Ast_52.Outcometree.out_class_sig_item ->
Ast_53.Outcometree.out_class_sig_item)
=
function
| Ast_52.Outcometree.Ocsg_constraint (x0, x1) ->
Ast_53.Outcometree.Ocsg_constraint
((copy_out_type x0), (copy_out_type x1))
| Ast_52.Outcometree.Ocsg_method (x0, x1, x2, x3) ->
Ast_53.Outcometree.Ocsg_method (x0, x1, x2, (copy_out_type x3))
| Ast_52.Outcometree.Ocsg_value (x0, x1, x2, x3) ->
Ast_53.Outcometree.Ocsg_value (x0, x1, x2, (copy_out_type x3))
and (copy_out_type_param :
Ast_52.Outcometree.out_type_param -> Ast_53.Outcometree.out_type_param)
=
fun
{ Ast_52.Outcometree.ot_non_gen = ot_non_gen;
Ast_52.Outcometree.ot_name = ot_name;
Ast_52.Outcometree.ot_variance = ot_variance }
->
{
Ast_53.Outcometree.ot_non_gen = ot_non_gen;
Ast_53.Outcometree.ot_name = ot_name;
Ast_53.Outcometree.ot_variance =
(let (x0, x1) = ot_variance in
((copy_variance x0), (copy_injectivity x1)))
}
and (copy_injectivity :
Ast_52.Asttypes.injectivity -> Ast_53.Asttypes.injectivity)
=
function
| Ast_52.Asttypes.Injective -> Ast_53.Asttypes.Injective
| Ast_52.Asttypes.NoInjectivity -> Ast_53.Asttypes.NoInjectivity
and (copy_variance : Ast_52.Asttypes.variance -> Ast_53.Asttypes.variance) =
function
| Ast_52.Asttypes.Covariant -> Ast_53.Asttypes.Covariant
| Ast_52.Asttypes.Contravariant -> Ast_53.Asttypes.Contravariant
| Ast_52.Asttypes.NoVariance -> Ast_53.Asttypes.NoVariance
and (copy_out_type :
Ast_52.Outcometree.out_type -> Ast_53.Outcometree.out_type)
=
function
| Ast_52.Outcometree.Otyp_abstract -> Ast_53.Outcometree.Otyp_abstract
| Ast_52.Outcometree.Otyp_open -> Ast_53.Outcometree.Otyp_open
| Ast_52.Outcometree.Otyp_alias {non_gen; aliased; alias} ->
Ast_53.Outcometree.Otyp_alias {non_gen; aliased=(copy_out_type aliased); alias}
| Ast_52.Outcometree.Otyp_arrow (x0, x1, x2) ->
Ast_53.Outcometree.Otyp_arrow
((copy_arg_label x0), (copy_out_type x1), (copy_out_type x2))
| Ast_52.Outcometree.Otyp_class (x0, x1) ->
Ast_53.Outcometree.Otyp_class
((copy_out_ident x0), (List.map (fun x -> copy_out_type x) x1))
| Ast_52.Outcometree.Otyp_constr (x0, x1) ->
Ast_53.Outcometree.Otyp_constr
((copy_out_ident x0), (List.map (fun x -> copy_out_type x) x1))
| Ast_52.Outcometree.Otyp_manifest (x0, x1) ->
Ast_53.Outcometree.Otyp_manifest
((copy_out_type x0), (copy_out_type x1))
| Ast_52.Outcometree.Otyp_object { fields; open_row } ->
Ast_53.Outcometree.Otyp_object
{ fields =
((List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1)))
fields));
open_row }
| Ast_52.Outcometree.Otyp_record x0 ->
Ast_53.Outcometree.Otyp_record
(List.map
(fun x -> let (x0, x1, x2) = x in
{ Ast_53.Outcometree.olab_name = x0
; olab_mut = if x1 then Mutable else Immutable
; olab_type = (copy_out_type x2)}) x0)
| Ast_52.Outcometree.Otyp_stuff x0 -> Ast_53.Outcometree.Otyp_stuff x0
| Ast_52.Outcometree.Otyp_sum x0 ->
Ast_53.Outcometree.Otyp_sum
(List.map (fun x -> copy_out_constructor x) x0)
| Ast_52.Outcometree.Otyp_tuple x0 ->
Ast_53.Outcometree.Otyp_tuple (List.map (fun x -> copy_out_type x) x0)
| Ast_52.Outcometree.Otyp_var (x0, x1) ->
Ast_53.Outcometree.Otyp_var (x0, x1)
| Ast_52.Outcometree.Otyp_variant (x0, x1, x2) ->
Ast_53.Outcometree.Otyp_variant
((copy_out_variant x0), x1,
(Option.map (fun x -> List.map (fun x -> x) x) x2))
| Ast_52.Outcometree.Otyp_poly (x0, x1) ->
Ast_53.Outcometree.Otyp_poly
((List.map (fun x -> x) x0), (copy_out_type x1))
| Ast_52.Outcometree.Otyp_module (x0, x1) ->
Ast_53.Outcometree.Otyp_module
((copy_out_ident x0),
(List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1)))
x1))
| Ast_52.Outcometree.Otyp_attribute (x0, x1) ->
Ast_53.Outcometree.Otyp_attribute
((copy_out_type x0), (copy_out_attribute x1))
and (copy_out_attribute :
Ast_52.Outcometree.out_attribute -> Ast_53.Outcometree.out_attribute)
=
fun { Ast_52.Outcometree.oattr_name = oattr_name } ->
{ Ast_53.Outcometree.oattr_name = oattr_name }
and (copy_out_variant :
Ast_52.Outcometree.out_variant -> Ast_53.Outcometree.out_variant)
=
function
| Ast_52.Outcometree.Ovar_fields x0 ->
Ast_53.Outcometree.Ovar_fields
(List.map
(fun x ->
let (x0, x1, x2) = x in
(x0, x1, (List.map (fun x -> copy_out_type x) x2))) x0)
| Ast_52.Outcometree.Ovar_typ x0 ->
Ast_53.Outcometree.Ovar_typ (copy_out_type x0)
and (copy_out_constructor :
Ast_52.Outcometree.out_constructor ->
Ast_53.Outcometree.out_constructor)
=
fun
{ Ast_52.Outcometree.ocstr_name = ocstr_name;
Ast_52.Outcometree.ocstr_args = ocstr_args;
Ast_52.Outcometree.ocstr_return_type = ocstr_return_type }
->
{
Ast_53.Outcometree.ocstr_name = ocstr_name;
Ast_53.Outcometree.ocstr_args =
(List.map (fun x -> copy_out_type x) ocstr_args);
Ast_53.Outcometree.ocstr_return_type =
(Option.map (fun x -> copy_out_type x) ocstr_return_type)
}
and (copy_arg_label : Ast_52.Asttypes.arg_label -> Ast_53.Asttypes.arg_label)
=
function
| Ast_52.Asttypes.Nolabel -> Ast_53.Asttypes.Nolabel
| Ast_52.Asttypes.Labelled x0 -> Ast_53.Asttypes.Labelled x0
| Ast_52.Asttypes.Optional x0 -> Ast_53.Asttypes.Optional x0
and (copy_out_value :
Ast_52.Outcometree.out_value -> Ast_53.Outcometree.out_value)
=
function
| Ast_52.Outcometree.Oval_array x0 ->
Ast_53.Outcometree.Oval_array (List.map (fun x -> copy_out_value x) x0)
| Ast_52.Outcometree.Oval_char x0 -> Ast_53.Outcometree.Oval_char x0
| Ast_52.Outcometree.Oval_constr (x0, x1) ->
Ast_53.Outcometree.Oval_constr
((copy_out_ident x0), (List.map (fun x -> copy_out_value x) x1))
| Ast_52.Outcometree.Oval_ellipsis -> Ast_53.Outcometree.Oval_ellipsis
| Ast_52.Outcometree.Oval_float x0 -> Ast_53.Outcometree.Oval_float x0
| Ast_52.Outcometree.Oval_int x0 -> Ast_53.Outcometree.Oval_int x0
| Ast_52.Outcometree.Oval_int32 x0 -> Ast_53.Outcometree.Oval_int32 x0
| Ast_52.Outcometree.Oval_int64 x0 -> Ast_53.Outcometree.Oval_int64 x0
| Ast_52.Outcometree.Oval_nativeint x0 ->
Ast_53.Outcometree.Oval_nativeint x0
| Ast_52.Outcometree.Oval_list x0 ->
Ast_53.Outcometree.Oval_list (List.map (fun x -> copy_out_value x) x0)
| Ast_52.Outcometree.Oval_printer x0 ->
Ast_53.Outcometree.Oval_printer (Caml_format_doc.deprecated_printer x0)
| Ast_52.Outcometree.Oval_record x0 ->
Ast_53.Outcometree.Oval_record
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_ident x0), (copy_out_value x1)))
x0)
| Ast_52.Outcometree.Oval_string (x0, x1, x2) ->
Ast_53.Outcometree.Oval_string (x0, x1, (copy_out_string x2))
| Ast_52.Outcometree.Oval_stuff x0 -> Ast_53.Outcometree.Oval_stuff x0
| Ast_52.Outcometree.Oval_tuple x0 ->
Ast_53.Outcometree.Oval_tuple (List.map (fun x -> copy_out_value x) x0)
| Ast_52.Outcometree.Oval_variant (x0, x1) ->
Ast_53.Outcometree.Oval_variant
(x0, (Option.map (fun x -> copy_out_value x) x1))
| Ast_52.Outcometree.Oval_lazy x0 ->
Ast_53.Outcometree.Oval_lazy (copy_out_value x0)
and (copy_out_string :
Ast_52.Outcometree.out_string -> Ast_53.Outcometree.out_string)
=
function
| Ast_52.Outcometree.Ostr_string -> Ast_53.Outcometree.Ostr_string
| Ast_52.Outcometree.Ostr_bytes -> Ast_53.Outcometree.Ostr_bytes
and (copy_out_ident :
Ast_52.Outcometree.out_ident -> Ast_53.Outcometree.out_ident)
=
function
| Ast_52.Outcometree.Oide_apply (x0, x1) ->
Ast_53.Outcometree.Oide_apply
((copy_out_ident x0), (copy_out_ident x1))
| Ast_52.Outcometree.Oide_dot (x0, x1) ->
Ast_53.Outcometree.Oide_dot ((copy_out_ident x0), x1)
| Ast_52.Outcometree.Oide_ident x0 ->
Ast_53.Outcometree.Oide_ident (copy_out_name x0)
and (copy_out_name :
Ast_52.Outcometree.out_name -> Ast_53.Outcometree.out_name)
=
fun { Ast_52.Outcometree.printed_name = printed_name } ->
{ Ast_53.Outcometree.printed_name = printed_name }
================================================
FILE: src/vendored-omp/src/migrate_parsetree_53_52.ml
================================================
include Migrate_parsetree_53_52_migrate
================================================
FILE: src/vendored-omp/src/migrate_parsetree_53_52_migrate.ml
================================================
open Stdlib0
module From = Ast_53
module To = Ast_52
let rec (copy_out_type_extension :
Ast_53.Outcometree.out_type_extension ->
Ast_52.Outcometree.out_type_extension)
=
fun
{ Ast_53.Outcometree.otyext_name = otyext_name;
Ast_53.Outcometree.otyext_params = otyext_params;
Ast_53.Outcometree.otyext_constructors = otyext_constructors;
Ast_53.Outcometree.otyext_private = otyext_private }
->
{
Ast_52.Outcometree.otyext_name = otyext_name;
Ast_52.Outcometree.otyext_params =
(List.map (fun x -> x) otyext_params);
Ast_52.Outcometree.otyext_constructors =
(List.map (fun x -> copy_out_constructor x) otyext_constructors);
Ast_52.Outcometree.otyext_private = (copy_private_flag otyext_private)
}
and (copy_out_phrase :
Ast_53.Outcometree.out_phrase -> Ast_52.Outcometree.out_phrase)
=
function
| Ast_53.Outcometree.Ophr_eval (x0, x1) ->
Ast_52.Outcometree.Ophr_eval ((copy_out_value x0), (copy_out_type x1))
| Ast_53.Outcometree.Ophr_signature x0 ->
Ast_52.Outcometree.Ophr_signature
(List.map
(fun x ->
let (x0, x1) = x in
((copy_out_sig_item x0),
(Option.map (fun x -> copy_out_value x) x1))) x0)
| Ast_53.Outcometree.Ophr_exception x0 ->
Ast_52.Outcometree.Ophr_exception
(let (x0, x1) = x0 in (x0, (copy_out_value x1)))
and (copy_out_sig_item :
Ast_53.Outcometree.out_sig_item -> Ast_52.Outcometree.out_sig_item)
=
function
| Ast_53.Outcometree.Osig_class (x0, x1, x2, x3, x4) ->
Ast_52.Outcometree.Osig_class
(x0, x1, (List.map (fun x -> copy_out_type_param x) x2),
(copy_out_class_type x3), (copy_out_rec_status x4))
| Ast_53.Outcometree.Osig_class_type (x0, x1, x2, x3, x4) ->
Ast_52.Outcometree.Osig_class_type
(x0, x1, (List.map (fun x -> copy_out_type_param x) x2),
(copy_out_class_type x3), (copy_out_rec_status x4))
| Ast_53.Outcometree.Osig_typext (x0, x1) ->
Ast_52.Outcometree.Osig_typext
((copy_out_extension_constructor x0), (copy_out_ext_status x1))
| Ast_53.Outcometree.Osig_modtype (x0, x1) ->
Ast_52.Outcometree.Osig_modtype (x0, (copy_out_module_type x1))
| Ast_53.Outcometree.Osig_module (x0, x1, x2) ->
Ast_52.Outcometree.Osig_module
(x0, (copy_out_module_type x1), (copy_out_rec_status x2))
| Ast_53.Outcometree.Osig_type (x0, x1) ->
Ast_52.Outcometree.Osig_type
((copy_out_type_decl x0), (copy_out_rec_status x1))
| Ast_53.Outcometree.Osig_value x0 ->
Ast_52.Outcometree.Osig_value (copy_out_val_decl x0)
| Ast_53.Outcometree.Osig_ellipsis -> Ast_52.Outcometree.Osig_ellipsis
and (copy_out_val_decl :
Ast_53.Outcometree.out_val_decl -> Ast_52.Outcometree.out_val_decl)
=
fun
{ Ast_53.Outcometree.oval_name = oval_name;
Ast_53.Outcometree.oval_type = oval_type;
Ast_53.Outcometree.oval_prims = oval_prims;
Ast_53.Outcometree.oval_attributes = oval_attributes }
->
{
Ast_52.Outcometree.oval_name = oval_name;
Ast_52.Outcometree.oval_type = (copy_out_type oval_type);
Ast_52.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims);
Ast_52.Outcometree.oval_attributes =
(List.map (fun x -> copy_out_attribute x) oval_attributes)
}
and (copy_out_type_decl :
Ast_53.Outcometree.out_type_decl -> Ast_52.Outcometree.out_type_decl)
=
fun
{ Ast_53.Outcometree.otype_name = otype_name;
Ast_53.Outcometree.otype_params = otype_params;
Ast_53.Outcometree.otype_type = otype_type;
Ast_53.Outcometree.otype_private = otype_private;
Ast_53.Outcometree.otype_immediate = otype_immediate;
Ast_53.Outcometree.otype_unboxed = otype_unboxed;
Ast_53.Outcometree.otype_cstrs = otype_cstrs }
->
{
Ast_52.Outcometree.otype_name = otype_name;
Ast_52.Outcometree.otype_params =
(List.map (fun x -> copy_out_type_param x) otype_params);
Ast_52.Outcometree.otype_type = (copy_out_type otype_type);
Ast_52.Outcometree.otype_private = (copy_private_flag otype_private);
Ast_52.Outcometree.otype_immediate =
(copy_Type_immediacy_t otype_immediate);
Ast_52.Outcometree.otype_unboxed = otype_unboxed;
Ast_52.Outcometree.otype_cstrs =
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_type x0), (copy_out_type x1)))
otype_cstrs)
}
and (copy_Type_immediacy_t :
Ast_53.Type_immediacy.t -> Ast_52.Type_immediacy.t)
=
function
| Ast_53.Type_immediacy.Unknown -> Ast_52.Type_immediacy.Unknown
| Ast_53.Type_immediacy.Always -> Ast_52.Type_immediacy.Always
| Ast_53.Type_immediacy.Always_on_64bits ->
Ast_52.Type_immediacy.Always_on_64bits
and (copy_out_module_type :
Ast_53.Outcometree.out_module_type ->
Ast_52.Outcometree.out_module_type)
=
function
| Ast_53.Outcometree.Omty_abstract -> Ast_52.Outcometree.Omty_abstract
| Ast_53.Outcometree.Omty_functor (x0, x1) ->
Ast_52.Outcometree.Omty_functor
((Option.map
(fun x ->
let (x0, x1) = x in
((Option.map (fun x -> x) x0), (copy_out_module_type x1))) x0),
(copy_out_module_type x1))
| Ast_53.Outcometree.Omty_ident x0 ->
Ast_52.Outcometree.Omty_ident (copy_out_ident x0)
| Ast_53.Outcometree.Omty_signature x0 ->
Ast_52.Outcometree.Omty_signature
(List.map (fun x -> copy_out_sig_item x) x0)
| Ast_53.Outcometree.Omty_alias x0 ->
Ast_52.Outcometree.Omty_alias (copy_out_ident x0)
and (copy_out_ext_status :
Ast_53.Outcometree.out_ext_status -> Ast_52.Outcometree.out_ext_status)
=
function
| Ast_53.Outcometree.Oext_first -> Ast_52.Outcometree.Oext_first
| Ast_53.Outcometree.Oext_next -> Ast_52.Outcometree.Oext_next
| Ast_53.Outcometree.Oext_exception -> Ast_52.Outcometree.Oext_exception
and (copy_out_extension_constructor :
Ast_53.Outcometree.out_extension_constructor ->
Ast_52.Outcometree.out_extension_constructor)
=
fun
{ Ast_53.Outcometree.oext_name = oext_name;
Ast_53.Outcometree.oext_type_name = oext_type_name;
Ast_53.Outcometree.oext_type_params = oext_type_params;
Ast_53.Outcometree.oext_args = oext_args;
Ast_53.Outcometree.oext_ret_type = oext_ret_type;
Ast_53.Outcometree.oext_private = oext_private }
->
{
Ast_52.Outcometree.oext_name = oext_name;
Ast_52.Outcometree.oext_type_name = oext_type_name;
Ast_52.Outcometree.oext_type_params =
(List.map (fun x -> x) oext_type_params);
Ast_52.Outcometree.oext_args =
(List.map (fun x -> copy_out_type x) oext_args);
Ast_52.Outcometree.oext_ret_type =
(Option.map (fun x -> copy_out_type x) oext_ret_type);
Ast_52.Outcometree.oext_private = (copy_private_flag oext_private)
}
and (copy_private_flag :
Ast_53.Asttypes.private_flag -> Ast_52.Asttypes.private_flag)
=
function
| Ast_53.Asttypes.Private -> Ast_52.Asttypes.Private
| Ast_53.Asttypes.Public -> Ast_52.Asttypes.Public
and (copy_out_rec_status :
Ast_53.Outcometree.out_rec_status -> Ast_52.Outcometree.out_rec_status)
=
function
| Ast_53.Outcometree.Orec_not -> Ast_52.Outcometree.Orec_not
| Ast_53.Outcometree.Orec_first -> Ast_52.Outcometree.Orec_first
| Ast_53.Outcometree.Orec_next -> Ast_52.Outcometree.Orec_next
and (copy_out_class_type :
Ast_53.Outcometree.out_class_type -> Ast_52.Outcometree.out_class_type)
=
function
| Ast_53.Outcometree.Octy_constr (x0, x1) ->
Ast_52.Outcometree.Octy_constr
((copy_out_ident x0), (List.map (fun x -> copy_out_type x) x1))
| Ast_53.Outcometree.Octy_arrow (x0, x1, x2) ->
Ast_52.Outcometree.Octy_arrow
((copy_arg_label x0), (copy_out_type x1), (copy_out_class_type x2))
| Ast_53.Outcometree.Octy_signature (x0, x1) ->
Ast_52.Outcometree.Octy_signature
((Option.map (fun x -> copy_out_type x) x0),
(List.map (fun x -> copy_out_class_sig_item x) x1))
and (copy_out_class_sig_item :
Ast_53.Outcometree.out_class_sig_item ->
Ast_52.Outcometree.out_class_sig_item)
=
function
| Ast_53.Outcometree.Ocsg_constraint (x0, x1) ->
Ast_52.Outcometree.Ocsg_constraint
((copy_out_type x0), (copy_out_type x1))
| Ast_53.Outcometree.Ocsg_method (x0, x1, x2, x3) ->
Ast_52.Outcometree.Ocsg_method (x0, x1, x2, (copy_out_type x3))
| Ast_53.Outcometree.Ocsg_value (x0, x1, x2, x3) ->
Ast_52.Outcometree.Ocsg_value (x0, x1, x2, (copy_out_type x3))
and (copy_out_type_param :
Ast_53.Outcometree.out_type_param -> Ast_52.Outcometree.out_type_param)
=
fun
{ Ast_53.Outcometree.ot_non_gen = ot_non_gen;
Ast_53.Outcometree.ot_name = ot_name;
Ast_53.Outcometree.ot_variance = ot_variance }
->
{
Ast_52.Outcometree.ot_non_gen = ot_non_gen;
Ast_52.Outcometree.ot_name = ot_name;
Ast_52.Outcometree.ot_variance =
(let (x0, x1) = ot_variance in
((copy_variance x0), (copy_injectivity x1)))
}
and (copy_injectivity :
Ast_53.Asttypes.injectivity -> Ast_52.Asttypes.injectivity)
=
function
| Ast_53.Asttypes.Injective -> Ast_52.Asttypes.Injective
| Ast_53.Asttypes.NoInjectivity -> Ast_52.Asttypes.NoInjectivity
and (copy_variance : Ast_53.Asttypes.variance -> Ast_52.Asttypes.variance) =
function
| Ast_53.Asttypes.Covariant -> Ast_52.Asttypes.Covariant
| Ast_53.Asttypes.Contravariant -> Ast_52.Asttypes.Contravariant
| Ast_53.Asttypes.NoVariance -> Ast_52.Asttypes.NoVariance
and (copy_out_type :
Ast_53.Outcometree.out_type -> Ast_52.Outcometree.out_type)
=
function
| Ast_53.Outcometree.Otyp_abstract -> Ast_52.Outcometree.Otyp_abstract
| Ast_53.Outcometree.Otyp_open -> Ast_52.Outcometree.Otyp_open
| Ast_53.Outcometree.Otyp_alias {non_gen; aliased; alias} ->
Ast_52.Outcometree.Otyp_alias {non_gen; aliased=(copy_out_type aliased); alias}
| Ast_53.Outcometree.Otyp_arrow (x0, x1, x2) ->
Ast_52.Outcometree.Otyp_arrow
((copy_arg_label x0), (copy_out_type x1), (copy_out_type x2))
| Ast_53.Outcometree.Otyp_class (x0, x1) ->
Ast_52.Outcometree.Otyp_class
((copy_out_ident x0), (List.map (fun x -> copy_out_type x) x1))
| Ast_53.Outcometree.Otyp_constr (x0, x1) ->
Ast_52.Outcometree.Otyp_constr
((copy_out_ident x0), (List.map (fun x -> copy_out_type x) x1))
| Ast_53.Outcometree.Otyp_manifest (x0, x1) ->
Ast_52.Outcometree.Otyp_manifest
((copy_out_type x0), (copy_out_type x1))
| Ast_53.Outcometree.Otyp_object { fields; open_row } ->
Ast_52.Outcometree.Otyp_object
{ fields =
((List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1)))
fields));
open_row }
| Ast_53.Outcometree.Otyp_record x0 ->
Ast_52.Outcometree.Otyp_record
(List.map (fun (x: Ast_53.Outcometree.out_label) ->
(x.olab_name, x.olab_mut = Mutable, copy_out_type x.olab_type)) x0)
| Ast_53.Outcometree.Otyp_stuff x0 -> Ast_52.Outcometree.Otyp_stuff x0
| Ast_53.Outcometree.Otyp_sum x0 ->
Ast_52.Outcometree.Otyp_sum
(List.map (fun x -> copy_out_constructor x) x0)
| Ast_53.Outcometree.Otyp_tuple x0 ->
Ast_52.Outcometree.Otyp_tuple (List.map (fun x -> copy_out_type x) x0)
| Ast_53.Outcometree.Otyp_var (x0, x1) ->
Ast_52.Outcometree.Otyp_var (x0, x1)
| Ast_53.Outcometree.Otyp_variant (x0, x1, x2) ->
Ast_52.Outcometree.Otyp_variant
((copy_out_variant x0), x1,
(Option.map (fun x -> List.map (fun x -> x) x) x2))
| Ast_53.Outcometree.Otyp_poly (x0, x1) ->
Ast_52.Outcometree.Otyp_poly
((List.map (fun x -> x) x0), (copy_out_type x1))
| Ast_53.Outcometree.Otyp_module (x0, x1) ->
Ast_52.Outcometree.Otyp_module
((copy_out_ident x0),
(List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1)))
x1))
| Ast_53.Outcometree.Otyp_attribute (x0, x1) ->
Ast_52.Outcometree.Otyp_attribute
((copy_out_type x0), (copy_out_attribute x1))
and (copy_out_attribute :
Ast_53.Outcometree.out_attribute -> Ast_52.Outcometree.out_attribute)
=
fun { Ast_53.Outcometree.oattr_name = oattr_name } ->
{ Ast_52.Outcometree.oattr_name = oattr_name }
and (copy_out_variant :
Ast_53.Outcometree.out_variant -> Ast_52.Outcometree.out_variant)
=
function
| Ast_53.Outcometree.Ovar_fields x0 ->
Ast_52.Outcometree.Ovar_fields
(List.map
(fun x ->
let (x0, x1, x2) = x in
(x0, x1, (List.map (fun x -> copy_out_type x) x2))) x0)
| Ast_53.Outcometree.Ovar_typ x0 ->
Ast_52.Outcometree.Ovar_typ (copy_out_type x0)
and (copy_out_constructor :
Ast_53.Outcometree.out_constructor ->
Ast_52.Outcometree.out_constructor)
=
fun
{ Ast_53.Outcometree.ocstr_name = ocstr_name;
Ast_53.Outcometree.ocstr_args = ocstr_args;
Ast_53.Outcometree.ocstr_return_type = ocstr_return_type }
->
{
Ast_52.Outcometree.ocstr_name = ocstr_name;
Ast_52.Outcometree.ocstr_args =
(List.map (fun x -> copy_out_type x) ocstr_args);
Ast_52.Outcometree.ocstr_return_type =
(Option.map (fun x -> copy_out_type x) ocstr_return_type)
}
and (copy_mutable_flag :
Ast_53.Asttypes.mutable_flag -> Ast_52.Asttypes.mutable_flag)
=
function
| Ast_53.Asttypes.Immutable -> Ast_52.Asttypes.Immutable
| Ast_53.Asttypes.Mutable -> Ast_52.Asttypes.Mutable
and (copy_arg_label : Ast_53.Asttypes.arg_label -> Ast_52.Asttypes.arg_label)
=
function
| Ast_53.Asttypes.Nolabel -> Ast_52.Asttypes.Nolabel
| Ast_53.Asttypes.Labelled x0 -> Ast_52.Asttypes.Labelled x0
| Ast_53.Asttypes.Optional x0 -> Ast_52.Asttypes.Optional x0
and (copy_out_value :
Ast_53.Outcometree.out_value -> Ast_52.Outcometree.out_value)
=
function
| Ast_53.Outcometree.Oval_array x0 ->
Ast_52.Outcometree.Oval_array (List.map (fun x -> copy_out_value x) x0)
| Ast_53.Outcometree.Oval_char x0 -> Ast_52.Outcometree.Oval_char x0
| Ast_53.Outcometree.Oval_constr (x0, x1) ->
Ast_52.Outcometree.Oval_constr
((copy_out_ident x0), (List.map (fun x -> copy_out_value x) x1))
| Ast_53.Outcometree.Oval_ellipsis -> Ast_52.Outcometree.Oval_ellipsis
| Ast_53.Outcometree.Oval_float x0 -> Ast_52.Outcometree.Oval_float x0
| Ast_53.Outcometree.Oval_int x0 -> Ast_52.Outcometree.Oval_int x0
| Ast_53.Outcometree.Oval_int32 x0 -> Ast_52.Outcometree.Oval_int32 x0
| Ast_53.Outcometree.Oval_int64 x0 -> Ast_52.Outcometree.Oval_int64 x0
| Ast_53.Outcometree.Oval_nativeint x0 ->
Ast_52.Outcometree.Oval_nativeint x0
| Ast_53.Outcometree.Oval_list x0 ->
Ast_52.Outcometree.Oval_list (List.map (fun x -> copy_out_value x) x0)
| Ast_53.Outcometree.Oval_printer x0 ->
Ast_52.Outcometree.Oval_printer (fun fmt ->
let f = Caml_format_doc.compat (fun fmt () -> x0 fmt) in
f fmt ())
| Ast_53.Outcometree.Oval_record x0 ->
Ast_52.Outcometree.Oval_record
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_ident x0), (copy_out_value x1)))
x0)
| Ast_53.Outcometree.Oval_string (x0, x1, x2) ->
Ast_52.Outcometree.Oval_string (x0, x1, (copy_out_string x2))
| Ast_53.Outcometree.Oval_stuff x0 -> Ast_52.Outcometree.Oval_stuff x0
| Ast_53.Outcometree.Oval_tuple x0 ->
Ast_52.Outcometree.Oval_tuple (List.map (fun x -> copy_out_value x) x0)
| Ast_53.Outcometree.Oval_variant (x0, x1) ->
Ast_52.Outcometree.Oval_variant
(x0, (Option.map (fun x -> copy_out_value x) x1))
| Ast_53.Outcometree.Oval_lazy x0 ->
Ast_52.Outcometree.Oval_lazy (copy_out_value x0)
and (copy_out_string :
Ast_53.Outcometree.out_string -> Ast_52.Outcometree.out_string)
=
function
| Ast_53.Outcometree.Ostr_string -> Ast_52.Outcometree.Ostr_string
| Ast_53.Outcometree.Ostr_bytes -> Ast_52.Outcometree.Ostr_bytes
and (copy_out_ident :
Ast_53.Outcometree.out_ident -> Ast_52.Outcometree.out_ident)
=
function
| Ast_53.Outcometree.Oide_apply (x0, x1) ->
Ast_52.Outcometree.Oide_apply
((copy_out_ident x0), (copy_out_ident x1))
| Ast_53.Outcometree.Oide_dot (x0, x1) ->
Ast_52.Outcometree.Oide_dot ((copy_out_ident x0), x1)
| Ast_53.Outcometree.Oide_ident x0 ->
Ast_52.Outcometree.Oide_ident (copy_out_name x0)
and (copy_out_name :
Ast_53.Outcometree.out_name -> Ast_52.Outcometree.out_name)
=
fun { Ast_53.Outcometree.printed_name = printed_name } ->
{ Ast_52.Outcometree.printed_name = printed_name }
================================================
FILE: src/vendored-omp/src/migrate_parsetree_53_54.ml
================================================
include Migrate_parsetree_53_54_migrate
================================================
FILE: src/vendored-omp/src/migrate_parsetree_53_54_migrate.ml
================================================
module From = Ast_53
module To = Ast_54
let rec (copy_out_type_extension :
Ast_53.Outcometree.out_type_extension ->
Ast_54.Outcometree.out_type_extension)
=
fun
{ Ast_53.Outcometree.otyext_name = otyext_name;
Ast_53.Outcometree.otyext_params = otyext_params;
Ast_53.Outcometree.otyext_constructors = otyext_constructors;
Ast_53.Outcometree.otyext_private = otyext_private }
->
{
Ast_54.Outcometree.otyext_name = otyext_name;
Ast_54.Outcometree.otyext_params =
(List.map (fun x -> x) otyext_params);
Ast_54.Outcometree.otyext_constructors =
(List.map (fun x -> copy_out_constructor x) otyext_constructors);
Ast_54.Outcometree.otyext_private = (copy_private_flag otyext_private)
}
and (copy_out_phrase :
Ast_53.Outcometree.out_phrase -> Ast_54.Outcometree.out_phrase)
=
function
| Ast_53.Outcometree.Ophr_eval (x0, x1) ->
Ast_54.Outcometree.Ophr_eval ((copy_out_value x0), (copy_out_type x1))
| Ast_53.Outcometree.Ophr_signature x0 ->
Ast_54.Outcometree.Ophr_signature
(List.map
(fun x ->
let (x0, x1) = x in
((copy_out_sig_item x0),
(Option.map (fun x -> copy_out_value x) x1))) x0)
| Ast_53.Outcometree.Ophr_exception x0 ->
Ast_54.Outcometree.Ophr_exception
(let (x0, x1) = x0 in (x0, (copy_out_value x1)))
and (copy_out_sig_item :
Ast_53.Outcometree.out_sig_item -> Ast_54.Outcometree.out_sig_item)
=
function
| Ast_53.Outcometree.Osig_class (x0, x1, x2, x3, x4) ->
Ast_54.Outcometree.Osig_class
(x0, x1, (List.map (fun x -> copy_out_type_param x) x2),
(copy_out_class_type x3), (copy_out_rec_status x4))
| Ast_53.Outcometree.Osig_class_type (x0, x1, x2, x3, x4) ->
Ast_54.Outcometree.Osig_class_type
(x0, x1, (List.map (fun x -> copy_out_type_param x) x2),
(copy_out_class_type x3), (copy_out_rec_status x4))
| Ast_53.Outcometree.Osig_typext (x0, x1) ->
Ast_54.Outcometree.Osig_typext
((copy_out_extension_constructor x0), (copy_out_ext_status x1))
| Ast_53.Outcometree.Osig_modtype (x0, x1) ->
Ast_54.Outcometree.Osig_modtype (x0, (copy_out_module_type x1))
| Ast_53.Outcometree.Osig_module (x0, x1, x2) ->
Ast_54.Outcometree.Osig_module
(x0, (copy_out_module_type x1), (copy_out_rec_status x2))
| Ast_53.Outcometree.Osig_type (x0, x1) ->
Ast_54.Outcometree.Osig_type
((copy_out_type_decl x0), (copy_out_rec_status x1))
| Ast_53.Outcometree.Osig_value x0 ->
Ast_54.Outcometree.Osig_value (copy_out_val_decl x0)
| Ast_53.Outcometree.Osig_ellipsis -> Ast_54.Outcometree.Osig_ellipsis
and (copy_out_val_decl :
Ast_53.Outcometree.out_val_decl -> Ast_54.Outcometree.out_val_decl)
=
fun
{ Ast_53.Outcometree.oval_name = oval_name;
Ast_53.Outcometree.oval_type = oval_type;
Ast_53.Outcometree.oval_prims = oval_prims;
Ast_53.Outcometree.oval_attributes = oval_attributes }
->
{
Ast_54.Outcometree.oval_name = oval_name;
Ast_54.Outcometree.oval_type = (copy_out_type oval_type);
Ast_54.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims);
Ast_54.Outcometree.oval_attributes =
(List.map (fun x -> copy_out_attribute x) oval_attributes)
}
and (copy_out_type_decl :
Ast_53.Outcometree.out_type_decl -> Ast_54.Outcometree.out_type_decl)
=
fun
{ Ast_53.Outcometree.otype_name = otype_name;
Ast_53.Outcometree.otype_params = otype_params;
Ast_53.Outcometree.otype_type = otype_type;
Ast_53.Outcometree.otype_private = otype_private;
Ast_53.Outcometree.otype_immediate = otype_immediate;
Ast_53.Outcometree.otype_unboxed = otype_unboxed;
Ast_53.Outcometree.otype_cstrs = otype_cstrs }
->
{
Ast_54.Outcometree.otype_name = otype_name;
Ast_54.Outcometree.otype_params =
(List.map (fun x -> copy_out_type_param x) otype_params);
Ast_54.Outcometree.otype_type = (copy_out_type otype_type);
Ast_54.Outcometree.otype_private = (copy_private_flag otype_private);
Ast_54.Outcometree.otype_immediate =
(copy_Type_immediacy_t otype_immediate);
Ast_54.Outcometree.otype_unboxed = otype_unboxed;
Ast_54.Outcometree.otype_cstrs =
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_type x0), (copy_out_type x1)))
otype_cstrs)
}
and (copy_Type_immediacy_t :
Ast_53.Type_immediacy.t -> Ast_54.Type_immediacy.t)
=
function
| Ast_53.Type_immediacy.Unknown -> Ast_54.Type_immediacy.Unknown
| Ast_53.Type_immediacy.Always -> Ast_54.Type_immediacy.Always
| Ast_53.Type_immediacy.Always_on_64bits ->
Ast_54.Type_immediacy.Always_on_64bits
and (copy_out_module_type :
Ast_53.Outcometree.out_module_type ->
Ast_54.Outcometree.out_module_type)
=
function
| Ast_53.Outcometree.Omty_abstract -> Ast_54.Outcometree.Omty_abstract
| Ast_53.Outcometree.Omty_functor (x0, x1) ->
Ast_54.Outcometree.Omty_functor
((Option.map
(fun x ->
let (x0, x1) = x in
((Option.map (fun x -> x) x0), (copy_out_module_type x1))) x0),
(copy_out_module_type x1))
| Ast_53.Outcometree.Omty_ident x0 ->
Ast_54.Outcometree.Omty_ident (copy_out_ident x0)
| Ast_53.Outcometree.Omty_signature x0 ->
Ast_54.Outcometree.Omty_signature
(List.map (fun x -> copy_out_sig_item x) x0)
| Ast_53.Outcometree.Omty_alias x0 ->
Ast_54.Outcometree.Omty_alias (copy_out_ident x0)
and (copy_out_ext_status :
Ast_53.Outcometree.out_ext_status -> Ast_54.Outcometree.out_ext_status)
=
function
| Ast_53.Outcometree.Oext_first -> Ast_54.Outcometree.Oext_first
| Ast_53.Outcometree.Oext_next -> Ast_54.Outcometree.Oext_next
| Ast_53.Outcometree.Oext_exception -> Ast_54.Outcometree.Oext_exception
and (copy_out_extension_constructor :
Ast_53.Outcometree.out_extension_constructor ->
Ast_54.Outcometree.out_extension_constructor)
=
fun
{ Ast_53.Outcometree.oext_name = oext_name;
Ast_53.Outcometree.oext_type_name = oext_type_name;
Ast_53.Outcometree.oext_type_params = oext_type_params;
Ast_53.Outcometree.oext_args = oext_args;
Ast_53.Outcometree.oext_ret_type = oext_ret_type;
Ast_53.Outcometree.oext_private = oext_private }
->
{
Ast_54.Outcometree.oext_name = oext_name;
Ast_54.Outcometree.oext_type_name = oext_type_name;
Ast_54.Outcometree.oext_type_params =
(List.map (fun x -> x) oext_type_params);
Ast_54.Outcometree.oext_args =
(List.map (fun x -> copy_out_type x) oext_args);
Ast_54.Outcometree.oext_ret_type =
(Option.map (fun x -> copy_out_type x) oext_ret_type);
Ast_54.Outcometree.oext_private = (copy_private_flag oext_private)
}
and (copy_private_flag :
Ast_53.Asttypes.private_flag -> Ast_54.Asttypes.private_flag)
=
function
| Ast_53.Asttypes.Private -> Ast_54.Asttypes.Private
| Ast_53.Asttypes.Public -> Ast_54.Asttypes.Public
and (copy_out_rec_status :
Ast_53.Outcometree.out_rec_status -> Ast_54.Outcometree.out_rec_status)
=
function
| Ast_53.Outcometree.Orec_not -> Ast_54.Outcometree.Orec_not
| Ast_53.Outcometree.Orec_first -> Ast_54.Outcometree.Orec_first
| Ast_53.Outcometree.Orec_next -> Ast_54.Outcometree.Orec_next
and (copy_out_class_type :
Ast_53.Outcometree.out_class_type -> Ast_54.Outcometree.out_class_type)
=
function
| Ast_53.Outcometree.Octy_constr (x0, x1) ->
Ast_54.Outcometree.Octy_constr
((copy_out_ident x0), (List.map (fun x -> copy_out_type x) x1))
| Ast_53.Outcometree.Octy_arrow (x0, x1, x2) ->
Ast_54.Outcometree.Octy_arrow
((copy_arg_label x0), (copy_out_type x1), (copy_out_class_type x2))
| Ast_53.Outcometree.Octy_signature (x0, x1) ->
Ast_54.Outcometree.Octy_signature
((Option.map (fun x -> copy_out_type x) x0),
(List.map (fun x -> copy_out_class_sig_item x) x1))
and (copy_out_class_sig_item :
Ast_53.Outcometree.out_class_sig_item ->
Ast_54.Outcometree.out_class_sig_item)
=
function
| Ast_53.Outcometree.Ocsg_constraint (x0, x1) ->
Ast_54.Outcometree.Ocsg_constraint
((copy_out_type x0), (copy_out_type x1))
| Ast_53.Outcometree.Ocsg_method (x0, x1, x2, x3) ->
Ast_54.Outcometree.Ocsg_method (x0, x1, x2, (copy_out_type x3))
| Ast_53.Outcometree.Ocsg_value (x0, x1, x2, x3) ->
Ast_54.Outcometree.Ocsg_value (x0, x1, x2, (copy_out_type x3))
and (copy_out_type_param :
Ast_53.Outcometree.out_type_param -> Ast_54.Outcometree.out_type_param)
=
fun
{ Ast_53.Outcometree.ot_non_gen = ot_non_gen;
Ast_53.Outcometree.ot_name = ot_name;
Ast_53.Outcometree.ot_variance = ot_variance }
->
{
Ast_54.Outcometree.ot_non_gen = ot_non_gen;
Ast_54.Outcometree.ot_name = ot_name;
Ast_54.Outcometree.ot_variance =
(let (x0, x1) = ot_variance in
((copy_variance x0), (copy_injectivity x1)))
}
and (copy_injectivity :
Ast_53.Asttypes.injectivity -> Ast_54.Asttypes.injectivity)
=
function
| Ast_53.Asttypes.Injective -> Ast_54.Asttypes.Injective
| Ast_53.Asttypes.NoInjectivity -> Ast_54.Asttypes.NoInjectivity
and (copy_variance : Ast_53.Asttypes.variance -> Ast_54.Asttypes.variance) =
function
| Ast_53.Asttypes.Covariant -> Ast_54.Asttypes.Covariant
| Ast_53.Asttypes.Contravariant -> Ast_54.Asttypes.Contravariant
| Ast_53.Asttypes.NoVariance -> Ast_54.Asttypes.NoVariance
and (copy_out_type :
Ast_53.Outcometree.out_type -> Ast_54.Outcometree.out_type)
=
function
| Ast_53.Outcometree.Otyp_abstract -> Ast_54.Outcometree.Otyp_abstract
| Ast_53.Outcometree.Otyp_open -> Ast_54.Outcometree.Otyp_open
| Ast_53.Outcometree.Otyp_alias {non_gen; aliased; alias} ->
Ast_54.Outcometree.Otyp_alias {non_gen; aliased=(copy_out_type aliased); alias}
| Ast_53.Outcometree.Otyp_arrow (x0, x1, x2) ->
Ast_54.Outcometree.Otyp_arrow
((copy_arg_label x0), (copy_out_type x1), (copy_out_type x2))
| Ast_53.Outcometree.Otyp_class (x0, x1) ->
Ast_54.Outcometree.Otyp_class
((copy_out_ident x0), (List.map (fun x -> copy_out_type x) x1))
| Ast_53.Outcometree.Otyp_constr (x0, x1) ->
Ast_54.Outcometree.Otyp_constr
((copy_out_ident x0), (List.map (fun x -> copy_out_type x) x1))
| Ast_53.Outcometree.Otyp_manifest (x0, x1) ->
Ast_54.Outcometree.Otyp_manifest
((copy_out_type x0), (copy_out_type x1))
| Ast_53.Outcometree.Otyp_object { fields; open_row } ->
Ast_54.Outcometree.Otyp_object
{ fields =
((List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1)))
fields));
open_row }
| Ast_53.Outcometree.Otyp_record x0 ->
Ast_54.Outcometree.Otyp_record
(List.map (fun x -> copy_out_label x) x0)
| Ast_53.Outcometree.Otyp_stuff x0 -> Ast_54.Outcometree.Otyp_stuff x0
| Ast_53.Outcometree.Otyp_sum x0 ->
Ast_54.Outcometree.Otyp_sum
(List.map (fun x -> copy_out_constructor x) x0)
| Ast_53.Outcometree.Otyp_tuple x0 ->
Ast_54.Outcometree.Otyp_tuple (List.map (fun x -> None, copy_out_type x) x0)
| Ast_53.Outcometree.Otyp_var (x0, x1) ->
Ast_54.Outcometree.Otyp_var (x0, x1)
| Ast_53.Outcometree.Otyp_variant (x0, x1, x2) ->
Ast_54.Outcometree.Otyp_variant
((copy_out_variant x0), x1,
(Option.map (fun x -> List.map (fun x -> x) x) x2))
| Ast_53.Outcometree.Otyp_poly (x0, x1) ->
Ast_54.Outcometree.Otyp_poly
((List.map (fun x -> x) x0), (copy_out_type x1))
| Ast_53.Outcometree.Otyp_module (x0, x1) ->
Ast_54.Outcometree.Otyp_module
{ opack_path = (copy_out_ident x0)
; opack_cstrs = (List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1)))
x1)}
| Ast_53.Outcometree.Otyp_attribute (x0, x1) ->
Ast_54.Outcometree.Otyp_attribute
((copy_out_type x0), (copy_out_attribute x1))
and (copy_out_attribute :
Ast_53.Outcometree.out_attribute -> Ast_54.Outcometree.out_attribute)
=
fun { Ast_53.Outcometree.oattr_name = oattr_name } ->
{ Ast_54.Outcometree.oattr_name = oattr_name }
and (copy_out_variant :
Ast_53.Outcometree.out_variant -> Ast_54.Outcometree.out_variant)
=
function
| Ast_53.Outcometree.Ovar_fields x0 ->
Ast_54.Outcometree.Ovar_fields
(List.map
(fun x ->
let (x0, x1, x2) = x in
(x0, x1, (List.map (fun x -> copy_out_type x) x2))) x0)
| Ast_53.Outcometree.Ovar_typ x0 ->
Ast_54.Outcometree.Ovar_typ (copy_out_type x0)
and (copy_out_constructor :
Ast_53.Outcometree.out_constructor ->
Ast_54.Outcometree.out_constructor)
=
fun
{ Ast_53.Outcometree.ocstr_name = ocstr_name;
Ast_53.Outcometree.ocstr_args = ocstr_args;
Ast_53.Outcometree.ocstr_return_type = ocstr_return_type }
->
{
Ast_54.Outcometree.ocstr_name = ocstr_name;
Ast_54.Outcometree.ocstr_args =
(List.map (fun x -> copy_out_type x) ocstr_args);
Ast_54.Outcometree.ocstr_return_type =
(Option.map (fun x -> copy_out_type x) ocstr_return_type)
}
and (copy_out_label :
Ast_53.Outcometree.out_label -> Ast_54.Outcometree.out_label)
=
fun
{ Ast_53.Outcometree.olab_name = olab_name;
Ast_53.Outcometree.olab_mut = olab_mut;
Ast_53.Outcometree.olab_type = olab_type }
->
{
Ast_54.Outcometree.olab_name = olab_name;
Ast_54.Outcometree.olab_mut = (copy_mutable_flag olab_mut);
Ast_54.Outcometree.olab_atomic = Ast_54.Asttypes.Nonatomic;
Ast_54.Outcometree.olab_type = (copy_out_type olab_type)
}
and (copy_mutable_flag :
Ast_53.Asttypes.mutable_flag -> Ast_54.Asttypes.mutable_flag)
=
function
| Ast_53.Asttypes.Immutable -> Ast_54.Asttypes.Immutable
| Ast_53.Asttypes.Mutable -> Ast_54.Asttypes.Mutable
and (copy_arg_label : Ast_53.Asttypes.arg_label -> Ast_54.Asttypes.arg_label)
=
function
| Ast_53.Asttypes.Nolabel -> Ast_54.Asttypes.Nolabel
| Ast_53.Asttypes.Labelled x0 -> Ast_54.Asttypes.Labelled x0
| Ast_53.Asttypes.Optional x0 -> Ast_54.Asttypes.Optional x0
and (copy_out_value :
Ast_53.Outcometree.out_value -> Ast_54.Outcometree.out_value)
=
function
| Ast_53.Outcometree.Oval_array x0 ->
Ast_54.Outcometree.Oval_array
((List.map (fun x -> copy_out_value x) x0), Ast_54.Asttypes.Mutable)
| Ast_53.Outcometree.Oval_char x0 -> Ast_54.Outcometree.Oval_char x0
| Ast_53.Outcometree.Oval_constr (x0, x1) ->
Ast_54.Outcometree.Oval_constr
((copy_out_ident x0), (List.map (fun x -> copy_out_value x) x1))
| Ast_53.Outcometree.Oval_ellipsis -> Ast_54.Outcometree.Oval_ellipsis
| Ast_53.Outcometree.Oval_float x0 -> Ast_54.Outcometree.Oval_float x0
| Ast_53.Outcometree.Oval_int x0 -> Ast_54.Outcometree.Oval_int x0
| Ast_53.Outcometree.Oval_int32 x0 -> Ast_54.Outcometree.Oval_int32 x0
| Ast_53.Outcometree.Oval_int64 x0 -> Ast_54.Outcometree.Oval_int64 x0
| Ast_53.Outcometree.Oval_nativeint x0 ->
Ast_54.Outcometree.Oval_nativeint x0
| Ast_53.Outcometree.Oval_list x0 ->
Ast_54.Outcometree.Oval_list (List.map (fun x -> copy_out_value x) x0)
| Ast_53.Outcometree.Oval_printer x0 -> Ast_54.Outcometree.Oval_printer x0
| Ast_53.Outcometree.Oval_record x0 ->
Ast_54.Outcometree.Oval_record
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_ident x0), (copy_out_value x1)))
x0)
| Ast_53.Outcometree.Oval_string (x0, x1, x2) ->
Ast_54.Outcometree.Oval_string (x0, x1, (copy_out_string x2))
| Ast_53.Outcometree.Oval_stuff x0 -> Ast_54.Outcometree.Oval_stuff x0
| Ast_53.Outcometree.Oval_tuple x0 ->
Ast_54.Outcometree.Oval_tuple (List.map (fun x -> None, copy_out_value x) x0)
| Ast_53.Outcometree.Oval_variant (x0, x1) ->
Ast_54.Outcometree.Oval_variant
(x0, (Option.map (fun x -> copy_out_value x) x1))
| Ast_53.Outcometree.Oval_lazy x0 ->
Ast_54.Outcometree.Oval_lazy (copy_out_value x0)
and (copy_out_string :
Ast_53.Outcometree.out_string -> Ast_54.Outcometree.out_string)
=
function
| Ast_53.Outcometree.Ostr_string -> Ast_54.Outcometree.Ostr_string
| Ast_53.Outcometree.Ostr_bytes -> Ast_54.Outcometree.Ostr_bytes
and (copy_out_ident :
Ast_53.Outcometree.out_ident -> Ast_54.Outcometree.out_ident)
=
function
| Ast_53.Outcometree.Oide_apply (x0, x1) ->
Ast_54.Outcometree.Oide_apply
((copy_out_ident x0), (copy_out_ident x1))
| Ast_53.Outcometree.Oide_dot (x0, x1) ->
Ast_54.Outcometree.Oide_dot ((copy_out_ident x0), x1)
| Ast_53.Outcometree.Oide_ident x0 ->
Ast_54.Outcometree.Oide_ident (copy_out_name x0)
and (copy_out_name :
Ast_53.Outcometree.out_name -> Ast_54.Outcometree.out_name)
=
fun { Ast_53.Outcometree.printed_name = printed_name } ->
{ Ast_54.Outcometree.printed_name = printed_name }
================================================
FILE: src/vendored-omp/src/migrate_parsetree_54_53.ml
================================================
include Migrate_parsetree_54_53_migrate
================================================
FILE: src/vendored-omp/src/migrate_parsetree_54_53_migrate.ml
================================================
module From = Ast_54
module To = Ast_53
let rec (copy_out_type_extension :
Ast_54.Outcometree.out_type_extension ->
Ast_53.Outcometree.out_type_extension)
=
fun
{ Ast_54.Outcometree.otyext_name = otyext_name;
Ast_54.Outcometree.otyext_params = otyext_params;
Ast_54.Outcometree.otyext_constructors = otyext_constructors;
Ast_54.Outcometree.otyext_private = otyext_private }
->
{
Ast_53.Outcometree.otyext_name = otyext_name;
Ast_53.Outcometree.otyext_params =
(List.map (fun x -> x) otyext_params);
Ast_53.Outcometree.otyext_constructors =
(List.map (fun x -> copy_out_constructor x) otyext_constructors);
Ast_53.Outcometree.otyext_private = (copy_private_flag otyext_private)
}
and (copy_out_phrase :
Ast_54.Outcometree.out_phrase -> Ast_53.Outcometree.out_phrase)
=
function
| Ast_54.Outcometree.Ophr_eval (x0, x1) ->
Ast_53.Outcometree.Ophr_eval ((copy_out_value x0), (copy_out_type x1))
| Ast_54.Outcometree.Ophr_signature x0 ->
Ast_53.Outcometree.Ophr_signature
(List.map
(fun x ->
let (x0, x1) = x in
((copy_out_sig_item x0),
(Option.map (fun x -> copy_out_value x) x1))) x0)
| Ast_54.Outcometree.Ophr_exception x0 ->
Ast_53.Outcometree.Ophr_exception
(let (x0, x1) = x0 in (x0, (copy_out_value x1)))
and (copy_out_sig_item :
Ast_54.Outcometree.out_sig_item -> Ast_53.Outcometree.out_sig_item)
=
function
| Ast_54.Outcometree.Osig_class (x0, x1, x2, x3, x4) ->
Ast_53.Outcometree.Osig_class
(x0, x1, (List.map (fun x -> copy_out_type_param x) x2),
(copy_out_class_type x3), (copy_out_rec_status x4))
| Ast_54.Outcometree.Osig_class_type (x0, x1, x2, x3, x4) ->
Ast_53.Outcometree.Osig_class_type
(x0, x1, (List.map (fun x -> copy_out_type_param x) x2),
(copy_out_class_type x3), (copy_out_rec_status x4))
| Ast_54.Outcometree.Osig_typext (x0, x1) ->
Ast_53.Outcometree.Osig_typext
((copy_out_extension_constructor x0), (copy_out_ext_status x1))
| Ast_54.Outcometree.Osig_modtype (x0, x1) ->
Ast_53.Outcometree.Osig_modtype (x0, (copy_out_module_type x1))
| Ast_54.Outcometree.Osig_module (x0, x1, x2) ->
Ast_53.Outcometree.Osig_module
(x0, (copy_out_module_type x1), (copy_out_rec_status x2))
| Ast_54.Outcometree.Osig_type (x0, x1) ->
Ast_53.Outcometree.Osig_type
((copy_out_type_decl x0), (copy_out_rec_status x1))
| Ast_54.Outcometree.Osig_value x0 ->
Ast_53.Outcometree.Osig_value (copy_out_val_decl x0)
| Ast_54.Outcometree.Osig_ellipsis -> Ast_53.Outcometree.Osig_ellipsis
and (copy_out_val_decl :
Ast_54.Outcometree.out_val_decl -> Ast_53.Outcometree.out_val_decl)
=
fun
{ Ast_54.Outcometree.oval_name = oval_name;
Ast_54.Outcometree.oval_type = oval_type;
Ast_54.Outcometree.oval_prims = oval_prims;
Ast_54.Outcometree.oval_attributes = oval_attributes }
->
{
Ast_53.Outcometree.oval_name = oval_name;
Ast_53.Outcometree.oval_type = (copy_out_type oval_type);
Ast_53.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims);
Ast_53.Outcometree.oval_attributes =
(List.map (fun x -> copy_out_attribute x) oval_attributes)
}
and (copy_out_type_decl :
Ast_54.Outcometree.out_type_decl -> Ast_53.Outcometree.out_type_decl)
=
fun
{ Ast_54.Outcometree.otype_name = otype_name;
Ast_54.Outcometree.otype_params = otype_params;
Ast_54.Outcometree.otype_type = otype_type;
Ast_54.Outcometree.otype_private = otype_private;
Ast_54.Outcometree.otype_immediate = otype_immediate;
Ast_54.Outcometree.otype_unboxed = otype_unboxed;
Ast_54.Outcometree.otype_cstrs = otype_cstrs }
->
{
Ast_53.Outcometree.otype_name = otype_name;
Ast_53.Outcometree.otype_params =
(List.map (fun x -> copy_out_type_param x) otype_params);
Ast_53.Outcometree.otype_type = (copy_out_type otype_type);
Ast_53.Outcometree.otype_private = (copy_private_flag otype_private);
Ast_53.Outcometree.otype_immediate =
(copy_Type_immediacy_t otype_immediate);
Ast_53.Outcometree.otype_unboxed = otype_unboxed;
Ast_53.Outcometree.otype_cstrs =
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_type x0), (copy_out_type x1)))
otype_cstrs)
}
and (copy_Type_immediacy_t :
Ast_54.Type_immediacy.t -> Ast_53.Type_immediacy.t)
=
function
| Ast_54.Type_immediacy.Unknown -> Ast_53.Type_immediacy.Unknown
| Ast_54.Type_immediacy.Always -> Ast_53.Type_immediacy.Always
| Ast_54.Type_immediacy.Always_on_64bits ->
Ast_53.Type_immediacy.Always_on_64bits
and (copy_out_module_type :
Ast_54.Outcometree.out_module_type ->
Ast_53.Outcometree.out_module_type)
=
function
| Ast_54.Outcometree.Omty_abstract -> Ast_53.Outcometree.Omty_abstract
| Ast_54.Outcometree.Omty_functor (x0, x1) ->
Ast_53.Outcometree.Omty_functor
((Option.map
(fun x ->
let (x0, x1) = x in
((Option.map (fun x -> x) x0), (copy_out_module_type x1))) x0),
(copy_out_module_type x1))
| Ast_54.Outcometree.Omty_ident x0 ->
Ast_53.Outcometree.Omty_ident (copy_out_ident x0)
| Ast_54.Outcometree.Omty_signature x0 ->
Ast_53.Outcometree.Omty_signature
(List.map (fun x -> copy_out_sig_item x) x0)
| Ast_54.Outcometree.Omty_alias x0 ->
Ast_53.Outcometree.Omty_alias (copy_out_ident x0)
and (copy_out_ext_status :
Ast_54.Outcometree.out_ext_status -> Ast_53.Outcometree.out_ext_status)
=
function
| Ast_54.Outcometree.Oext_first -> Ast_53.Outcometree.Oext_first
| Ast_54.Outcometree.Oext_next -> Ast_53.Outcometree.Oext_next
| Ast_54.Outcometree.Oext_exception -> Ast_53.Outcometree.Oext_exception
and (copy_out_extension_constructor :
Ast_54.Outcometree.out_extension_constructor ->
Ast_53.Outcometree.out_extension_constructor)
=
fun
{ Ast_54.Outcometree.oext_name = oext_name;
Ast_54.Outcometree.oext_type_name = oext_type_name;
Ast_54.Outcometree.oext_type_params = oext_type_params;
Ast_54.Outcometree.oext_args = oext_args;
Ast_54.Outcometree.oext_ret_type = oext_ret_type;
Ast_54.Outcometree.oext_private = oext_private }
->
{
Ast_53.Outcometree.oext_name = oext_name;
Ast_53.Outcometree.oext_type_name = oext_type_name;
Ast_53.Outcometree.oext_type_params =
(List.map (fun x -> x) oext_type_params);
Ast_53.Outcometree.oext_args =
(List.map (fun x -> copy_out_type x) oext_args);
Ast_53.Outcometree.oext_ret_type =
(Option.map (fun x -> copy_out_type x) oext_ret_type);
Ast_53.Outcometree.oext_private = (copy_private_flag oext_private)
}
and (copy_private_flag :
Ast_54.Asttypes.private_flag -> Ast_53.Asttypes.private_flag)
=
function
| Ast_54.Asttypes.Private -> Ast_53.Asttypes.Private
| Ast_54.Asttypes.Public -> Ast_53.Asttypes.Public
and (copy_out_rec_status :
Ast_54.Outcometree.out_rec_status -> Ast_53.Outcometree.out_rec_status)
=
function
| Ast_54.Outcometree.Orec_not -> Ast_53.Outcometree.Orec_not
| Ast_54.Outcometree.Orec_first -> Ast_53.Outcometree.Orec_first
| Ast_54.Outcometree.Orec_next -> Ast_53.Outcometree.Orec_next
and (copy_out_class_type :
Ast_54.Outcometree.out_class_type -> Ast_53.Outcometree.out_class_type)
=
function
| Ast_54.Outcometree.Octy_constr (x0, x1) ->
Ast_53.Outcometree.Octy_constr
((copy_out_ident x0), (List.map (fun x -> copy_out_type x) x1))
| Ast_54.Outcometree.Octy_arrow (x0, x1, x2) ->
Ast_53.Outcometree.Octy_arrow
((copy_arg_label x0), (copy_out_type x1), (copy_out_class_type x2))
| Ast_54.Outcometree.Octy_signature (x0, x1) ->
Ast_53.Outcometree.Octy_signature
((Option.map (fun x -> copy_out_type x) x0),
(List.map (fun x -> copy_out_class_sig_item x) x1))
and (copy_out_class_sig_item :
Ast_54.Outcometree.out_class_sig_item ->
Ast_53.Outcometree.out_class_sig_item)
=
function
| Ast_54.Outcometree.Ocsg_constraint (x0, x1) ->
Ast_53.Outcometree.Ocsg_constraint
((copy_out_type x0), (copy_out_type x1))
| Ast_54.Outcometree.Ocsg_method (x0, x1, x2, x3) ->
Ast_53.Outcometree.Ocsg_method (x0, x1, x2, (copy_out_type x3))
| Ast_54.Outcometree.Ocsg_value (x0, x1, x2, x3) ->
Ast_53.Outcometree.Ocsg_value (x0, x1, x2, (copy_out_type x3))
and (copy_out_type_param :
Ast_54.Outcometree.out_type_param -> Ast_53.Outcometree.out_type_param)
=
fun
{ Ast_54.Outcometree.ot_non_gen = ot_non_gen;
Ast_54.Outcometree.ot_name = ot_name;
Ast_54.Outcometree.ot_variance = ot_variance }
->
{
Ast_53.Outcometree.ot_non_gen = ot_non_gen;
Ast_53.Outcometree.ot_name = ot_name;
Ast_53.Outcometree.ot_variance =
(let (x0, x1) = ot_variance in
((copy_variance x0), (copy_injectivity x1)))
}
and (copy_injectivity :
Ast_54.Asttypes.injectivity -> Ast_53.Asttypes.injectivity)
=
function
| Ast_54.Asttypes.Injective -> Ast_53.Asttypes.Injective
| Ast_54.Asttypes.NoInjectivity -> Ast_53.Asttypes.NoInjectivity
and (copy_variance : Ast_54.Asttypes.variance -> Ast_53.Asttypes.variance) =
function
| Ast_54.Asttypes.Covariant -> Ast_53.Asttypes.Covariant
| Ast_54.Asttypes.Contravariant -> Ast_53.Asttypes.Contravariant
| Ast_54.Asttypes.NoVariance -> Ast_53.Asttypes.NoVariance
| Ast_54.Asttypes.Bivariant ->
(* TODO(anmonteiro): this is likely not correct? *)
Ast_53.Asttypes.NoVariance
and (copy_out_type :
Ast_54.Outcometree.out_type -> Ast_53.Outcometree.out_type)
=
function
| Ast_54.Outcometree.Otyp_abstract -> Ast_53.Outcometree.Otyp_abstract
| Ast_54.Outcometree.Otyp_open -> Ast_53.Outcometree.Otyp_open
| Ast_54.Outcometree.Otyp_alias {non_gen; aliased; alias} ->
Ast_53.Outcometree.Otyp_alias {non_gen; aliased=(copy_out_type aliased); alias}
| Ast_54.Outcometree.Otyp_arrow (x0, x1, x2) ->
Ast_53.Outcometree.Otyp_arrow
((copy_arg_label x0), (copy_out_type x1), (copy_out_type x2))
| Ast_54.Outcometree.Otyp_class (x0, x1) ->
Ast_53.Outcometree.Otyp_class
((copy_out_ident x0), (List.map (fun x -> copy_out_type x) x1))
| Ast_54.Outcometree.Otyp_constr (x0, x1) ->
Ast_53.Outcometree.Otyp_constr
((copy_out_ident x0), (List.map (fun x -> copy_out_type x) x1))
| Ast_54.Outcometree.Otyp_manifest (x0, x1) ->
Ast_53.Outcometree.Otyp_manifest
((copy_out_type x0), (copy_out_type x1))
| Ast_54.Outcometree.Otyp_object { fields; open_row } ->
Ast_53.Outcometree.Otyp_object
{ fields =
((List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1)))
fields));
open_row }
| Ast_54.Outcometree.Otyp_record x0 ->
Ast_53.Outcometree.Otyp_record
(List.map (fun x -> copy_out_label x) x0)
| Ast_54.Outcometree.Otyp_stuff x0 -> Ast_53.Outcometree.Otyp_stuff x0
| Ast_54.Outcometree.Otyp_sum x0 ->
Ast_53.Outcometree.Otyp_sum
(List.map (fun x -> copy_out_constructor x) x0)
| Ast_54.Outcometree.Otyp_tuple x0 ->
Ast_53.Outcometree.Otyp_tuple
(List.map
(fun x ->
let (_x0, x1) = x in
(copy_out_type x1)) x0)
| Ast_54.Outcometree.Otyp_var (x0, x1) ->
Ast_53.Outcometree.Otyp_var (x0, x1)
| Ast_54.Outcometree.Otyp_variant (x0, x1, x2) ->
Ast_53.Outcometree.Otyp_variant
((copy_out_variant x0), x1,
(Option.map (fun x -> List.map (fun x -> x) x) x2))
| Ast_54.Outcometree.Otyp_poly (x0, x1) ->
Ast_53.Outcometree.Otyp_poly
((List.map (fun x -> x) x0), (copy_out_type x1))
| Ast_54.Outcometree.Otyp_module
{ Ast_54.Outcometree.opack_path = opack_path;
Ast_54.Outcometree.opack_cstrs = opack_cstrs } ->
Ast_53.Outcometree.Otyp_module
((copy_out_ident opack_path),
(List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1)))
opack_cstrs))
| Ast_54.Outcometree.Otyp_attribute (x0, x1) ->
Ast_53.Outcometree.Otyp_attribute
((copy_out_type x0), (copy_out_attribute x1))
and (copy_out_attribute :
Ast_54.Outcometree.out_attribute -> Ast_53.Outcometree.out_attribute)
=
fun { Ast_54.Outcometree.oattr_name = oattr_name } ->
{ Ast_53.Outcometree.oattr_name = oattr_name }
and (copy_out_variant :
Ast_54.Outcometree.out_variant -> Ast_53.Outcometree.out_variant)
=
function
| Ast_54.Outcometree.Ovar_fields x0 ->
Ast_53.Outcometree.Ovar_fields
(List.map
(fun x ->
let (x0, x1, x2) = x in
(x0, x1, (List.map (fun x -> copy_out_type x) x2))) x0)
| Ast_54.Outcometree.Ovar_typ x0 ->
Ast_53.Outcometree.Ovar_typ (copy_out_type x0)
and (copy_out_constructor :
Ast_54.Outcometree.out_constructor ->
Ast_53.Outcometree.out_constructor)
=
fun
{ Ast_54.Outcometree.ocstr_name = ocstr_name;
Ast_54.Outcometree.ocstr_args = ocstr_args;
Ast_54.Outcometree.ocstr_return_type = ocstr_return_type }
->
{
Ast_53.Outcometree.ocstr_name = ocstr_name;
Ast_53.Outcometree.ocstr_args =
(List.map (fun x -> copy_out_type x) ocstr_args);
Ast_53.Outcometree.ocstr_return_type =
(Option.map (fun x -> copy_out_type x) ocstr_return_type)
}
and (copy_out_label :
Ast_54.Outcometree.out_label -> Ast_53.Outcometree.out_label)
=
fun
{ Ast_54.Outcometree.olab_name = olab_name;
Ast_54.Outcometree.olab_mut = olab_mut;
Ast_54.Outcometree.olab_atomic = _;
Ast_54.Outcometree.olab_type = olab_type }
->
{
Ast_53.Outcometree.olab_name = olab_name;
Ast_53.Outcometree.olab_mut = (copy_mutable_flag olab_mut);
Ast_53.Outcometree.olab_type = (copy_out_type olab_type)
}
and (copy_arg_label : Ast_54.Asttypes.arg_label -> Ast_53.Asttypes.arg_label)
=
function
| Ast_54.Asttypes.Nolabel -> Ast_53.Asttypes.Nolabel
| Ast_54.Asttypes.Labelled x0 -> Ast_53.Asttypes.Labelled x0
| Ast_54.Asttypes.Optional x0 -> Ast_53.Asttypes.Optional x0
and (copy_out_value :
Ast_54.Outcometree.out_value -> Ast_53.Outcometree.out_value)
=
function
| Ast_54.Outcometree.Oval_array (x0, _x1) ->
Ast_53.Outcometree.Oval_array
((List.map (fun x -> copy_out_value x) x0))
| Ast_54.Outcometree.Oval_char x0 -> Ast_53.Outcometree.Oval_char x0
| Ast_54.Outcometree.Oval_constr (x0, x1) ->
Ast_53.Outcometree.Oval_constr
((copy_out_ident x0), (List.map (fun x -> copy_out_value x) x1))
| Ast_54.Outcometree.Oval_ellipsis -> Ast_53.Outcometree.Oval_ellipsis
| Ast_54.Outcometree.Oval_float x0 -> Ast_53.Outcometree.Oval_float x0
| Ast_54.Outcometree.Oval_int x0 -> Ast_53.Outcometree.Oval_int x0
| Ast_54.Outcometree.Oval_int32 x0 -> Ast_53.Outcometree.Oval_int32 x0
| Ast_54.Outcometree.Oval_int64 x0 -> Ast_53.Outcometree.Oval_int64 x0
| Ast_54.Outcometree.Oval_nativeint x0 ->
Ast_53.Outcometree.Oval_nativeint x0
| Ast_54.Outcometree.Oval_list x0 ->
Ast_53.Outcometree.Oval_list (List.map (fun x -> copy_out_value x) x0)
| Ast_54.Outcometree.Oval_printer x0 -> Ast_53.Outcometree.Oval_printer x0
| Ast_54.Outcometree.Oval_record x0 ->
Ast_53.Outcometree.Oval_record
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_ident x0), (copy_out_value x1)))
x0)
| Ast_54.Outcometree.Oval_string (x0, x1, x2) ->
Ast_53.Outcometree.Oval_string (x0, x1, (copy_out_string x2))
| Ast_54.Outcometree.Oval_stuff x0 -> Ast_53.Outcometree.Oval_stuff x0
| Ast_54.Outcometree.Oval_tuple x0 ->
Ast_53.Outcometree.Oval_tuple
(List.map
(fun x ->
let (_x0, x1) = x in
(copy_out_value x1)) x0)
| Ast_54.Outcometree.Oval_variant (x0, x1) ->
Ast_53.Outcometree.Oval_variant
(x0, (Option.map (fun x -> copy_out_value x) x1))
| Ast_54.Outcometree.Oval_lazy x0 ->
Ast_53.Outcometree.Oval_lazy (copy_out_value x0)
| Ast_54.Outcometree.Oval_floatarray x0 ->
let migrate x0 acc n =
match n with
| 0 -> acc
| i ->
Ast_53.Outcometree.Oval_float (Array.Floatarray.get x0 (i - 1)) :: acc
in
Ast_53.Outcometree.Oval_array (migrate x0 [] (Array.Floatarray.length x0))
and (copy_out_string :
Ast_54.Outcometree.out_string -> Ast_53.Outcometree.out_string)
=
function
| Ast_54.Outcometree.Ostr_string -> Ast_53.Outcometree.Ostr_string
| Ast_54.Outcometree.Ostr_bytes -> Ast_53.Outcometree.Ostr_bytes
and (copy_out_ident :
Ast_54.Outcometree.out_ident -> Ast_53.Outcometree.out_ident)
=
function
| Ast_54.Outcometree.Oide_apply (x0, x1) ->
Ast_53.Outcometree.Oide_apply
((copy_out_ident x0), (copy_out_ident x1))
| Ast_54.Outcometree.Oide_dot (x0, x1) ->
Ast_53.Outcometree.Oide_dot ((copy_out_ident x0), x1)
| Ast_54.Outcometree.Oide_ident x0 ->
Ast_53.Outcometree.Oide_ident (copy_out_name x0)
and (copy_out_name :
Ast_54.Outcometree.out_name -> Ast_53.Outcometree.out_name)
=
fun { Ast_54.Outcometree.printed_name = printed_name } ->
{ Ast_53.Outcometree.printed_name = printed_name }
and (copy_mutable_flag :
Ast_54.Asttypes.mutable_flag -> Ast_53.Asttypes.mutable_flag)
=
function
| Ast_54.Asttypes.Immutable -> Ast_53.Asttypes.Immutable
| Ast_54.Asttypes.Mutable -> Ast_53.Asttypes.Mutable
================================================
FILE: src/vendored-omp/src/migrate_parsetree_54_55.ml
================================================
include Migrate_parsetree_54_55_migrate
================================================
FILE: src/vendored-omp/src/migrate_parsetree_54_55_migrate.ml
================================================
module From = Ast_54
module To = Ast_55
let rec (copy_out_type_extension :
Ast_54.Outcometree.out_type_extension ->
Ast_55.Outcometree.out_type_extension)
=
fun
{ Ast_54.Outcometree.otyext_name = otyext_name;
Ast_54.Outcometree.otyext_params = otyext_params;
Ast_54.Outcometree.otyext_constructors = otyext_constructors;
Ast_54.Outcometree.otyext_private = otyext_private }
->
{
Ast_55.Outcometree.otyext_name = otyext_name;
Ast_55.Outcometree.otyext_params =
(List.map (fun x ->
{ Ast_55.Outcometree.ot_non_gen = false
; ot_name = x
; ot_variance = (NoVariance, NoInjectivity)
})
otyext_params);
Ast_55.Outcometree.otyext_constructors =
(List.map (fun x -> copy_out_constructor x) otyext_constructors);
Ast_55.Outcometree.otyext_private = (copy_private_flag otyext_private)
}
and (copy_out_phrase :
Ast_54.Outcometree.out_phrase -> Ast_55.Outcometree.out_phrase)
=
function
| Ast_54.Outcometree.Ophr_eval (x0, x1) ->
Ast_55.Outcometree.Ophr_eval ((copy_out_value x0), (copy_out_type x1))
| Ast_54.Outcometree.Ophr_signature x0 ->
Ast_55.Outcometree.Ophr_signature
(List.map
(fun x ->
let (x0, x1) = x in
((copy_out_sig_item x0),
(Option.map (fun x -> copy_out_value x) x1))) x0)
| Ast_54.Outcometree.Ophr_exception x0 ->
Ast_55.Outcometree.Ophr_exception
(let (x0, x1) = x0 in (x0, (copy_out_value x1)))
and (copy_out_sig_item :
Ast_54.Outcometree.out_sig_item -> Ast_55.Outcometree.out_sig_item)
=
function
| Ast_54.Outcometree.Osig_class (x0, x1, x2, x3, x4) ->
Ast_55.Outcometree.Osig_class
(x0, x1, (List.map (fun x -> copy_out_type_param x) x2),
(copy_out_class_type x3), (copy_out_rec_status x4))
| Ast_54.Outcometree.Osig_class_type (x0, x1, x2, x3, x4) ->
Ast_55.Outcometree.Osig_class_type
(x0, x1, (List.map (fun x -> copy_out_type_param x) x2),
(copy_out_class_type x3), (copy_out_rec_status x4))
| Ast_54.Outcometree.Osig_typext (x0, x1) ->
Ast_55.Outcometree.Osig_typext
((copy_out_extension_constructor x0), (copy_out_ext_status x1))
| Ast_54.Outcometree.Osig_modtype (x0, x1) ->
Ast_55.Outcometree.Osig_modtype (x0, (copy_out_module_type x1))
| Ast_54.Outcometree.Osig_module (x0, x1, x2) ->
Ast_55.Outcometree.Osig_module
(x0, (copy_out_module_type x1), (copy_out_rec_status x2))
| Ast_54.Outcometree.Osig_type (x0, x1) ->
Ast_55.Outcometree.Osig_type
((copy_out_type_decl x0), (copy_out_rec_status x1))
| Ast_54.Outcometree.Osig_value x0 ->
Ast_55.Outcometree.Osig_value (copy_out_val_decl x0)
| Ast_54.Outcometree.Osig_ellipsis -> Ast_55.Outcometree.Osig_ellipsis
and (copy_out_val_decl :
Ast_54.Outcometree.out_val_decl -> Ast_55.Outcometree.out_val_decl)
=
fun
{ Ast_54.Outcometree.oval_name = oval_name;
Ast_54.Outcometree.oval_type = oval_type;
Ast_54.Outcometree.oval_prims = oval_prims;
Ast_54.Outcometree.oval_attributes = oval_attributes }
->
{
Ast_55.Outcometree.oval_name = oval_name;
Ast_55.Outcometree.oval_type = (copy_out_type oval_type);
Ast_55.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims);
Ast_55.Outcometree.oval_attributes =
(List.map (fun x -> copy_out_attribute x) oval_attributes)
}
and (copy_out_type_decl :
Ast_54.Outcometree.out_type_decl -> Ast_55.Outcometree.out_type_decl)
=
fun
{ Ast_54.Outcometree.otype_name = otype_name;
Ast_54.Outcometree.otype_params = otype_params;
Ast_54.Outcometree.otype_type = otype_type;
Ast_54.Outcometree.otype_private = otype_private;
Ast_54.Outcometree.otype_immediate = otype_immediate;
Ast_54.Outcometree.otype_unboxed = otype_unboxed;
Ast_54.Outcometree.otype_cstrs = otype_cstrs }
->
{
Ast_55.Outcometree.otype_name = otype_name;
Ast_55.Outcometree.otype_params =
(List.map (fun x -> copy_out_type_param x) otype_params);
Ast_55.Outcometree.otype_type = (copy_out_type otype_type);
Ast_55.Outcometree.otype_private = (copy_private_flag otype_private);
Ast_55.Outcometree.otype_immediate =
(copy_Type_immediacy_t otype_immediate);
Ast_55.Outcometree.otype_unboxed = otype_unboxed;
Ast_55.Outcometree.otype_constraints =
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_type x0), (copy_out_type x1)))
otype_cstrs)
}
and (copy_Type_immediacy_t :
Ast_54.Type_immediacy.t -> Ast_55.Type_immediacy.t)
=
function
| Ast_54.Type_immediacy.Unknown -> Ast_55.Type_immediacy.Unknown
| Ast_54.Type_immediacy.Always -> Ast_55.Type_immediacy.Always
| Ast_54.Type_immediacy.Always_on_64bits ->
Ast_55.Type_immediacy.Always_on_64bits
and (copy_out_module_type :
Ast_54.Outcometree.out_module_type ->
Ast_55.Outcometree.out_module_type)
=
function
| Ast_54.Outcometree.Omty_abstract -> Ast_55.Outcometree.Omty_abstract
| Ast_54.Outcometree.Omty_functor (x0, x1) ->
Ast_55.Outcometree.Omty_functor
((Option.map
(fun x ->
let (x0, x1) = x in
((Option.map (fun x -> x) x0), (copy_out_module_type x1))) x0),
(copy_out_module_type x1))
| Ast_54.Outcometree.Omty_ident x0 ->
Ast_55.Outcometree.Omty_ident (copy_out_ident x0)
| Ast_54.Outcometree.Omty_signature x0 ->
Ast_55.Outcometree.Omty_signature
(List.map (fun x -> copy_out_sig_item x) x0)
| Ast_54.Outcometree.Omty_alias x0 ->
Ast_55.Outcometree.Omty_alias (copy_out_ident x0)
and (copy_out_ext_status :
Ast_54.Outcometree.out_ext_status -> Ast_55.Outcometree.out_ext_status)
=
function
| Ast_54.Outcometree.Oext_first -> Ast_55.Outcometree.Oext_first
| Ast_54.Outcometree.Oext_next -> Ast_55.Outcometree.Oext_next
| Ast_54.Outcometree.Oext_exception -> Ast_55.Outcometree.Oext_exception
and (copy_out_extension_constructor :
Ast_54.Outcometree.out_extension_constructor ->
Ast_55.Outcometree.out_extension_constructor)
=
fun
{ Ast_54.Outcometree.oext_name = oext_name;
Ast_54.Outcometree.oext_type_name = oext_type_name;
Ast_54.Outcometree.oext_type_params = oext_type_params;
Ast_54.Outcometree.oext_args = oext_args;
Ast_54.Outcometree.oext_ret_type = oext_ret_type;
Ast_54.Outcometree.oext_private = oext_private }
->
{
Ast_55.Outcometree.oext_name = oext_name;
Ast_55.Outcometree.oext_type_name = oext_type_name;
Ast_55.Outcometree.oext_type_params =
(List.map (fun x ->
{ Ast_55.Outcometree.ot_non_gen = false
; ot_name = x
; ot_variance = (NoVariance, NoInjectivity)
})
oext_type_params
);
Ast_55.Outcometree.oext_args =
(List.map (fun x -> copy_out_type x) oext_args);
Ast_55.Outcometree.oext_ret_type =
(Option.map (fun x -> copy_out_type x) oext_ret_type);
Ast_55.Outcometree.oext_private = (copy_private_flag oext_private)
}
and (copy_private_flag :
Ast_54.Asttypes.private_flag -> Ast_55.Asttypes.private_flag)
=
function
| Ast_54.Asttypes.Private -> Ast_55.Asttypes.Private
| Ast_54.Asttypes.Public -> Ast_55.Asttypes.Public
and (copy_out_rec_status :
Ast_54.Outcometree.out_rec_status -> Ast_55.Outcometree.out_rec_status)
=
function
| Ast_54.Outcometree.Orec_not -> Ast_55.Outcometree.Orec_not
| Ast_54.Outcometree.Orec_first -> Ast_55.Outcometree.Orec_first
| Ast_54.Outcometree.Orec_next -> Ast_55.Outcometree.Orec_next
and (copy_out_class_type :
Ast_54.Outcometree.out_class_type -> Ast_55.Outcometree.out_class_type)
=
function
| Ast_54.Outcometree.Octy_constr (x0, x1) ->
Ast_55.Outcometree.Octy_constr
((copy_out_ident x0), (List.map (fun x -> copy_out_type x) x1))
| Ast_54.Outcometree.Octy_arrow (x0, x1, x2) ->
Ast_55.Outcometree.Octy_arrow
((copy_arg_label x0), (copy_out_type x1), (copy_out_class_type x2))
| Ast_54.Outcometree.Octy_signature (x0, x1) ->
Ast_55.Outcometree.Octy_signature
((Option.map (fun x -> copy_out_type x) x0),
(List.map (fun x -> copy_out_class_sig_item x) x1))
and (copy_out_class_sig_item :
Ast_54.Outcometree.out_class_sig_item ->
Ast_55.Outcometree.out_class_sig_item)
=
function
| Ast_54.Outcometree.Ocsg_constraint (x0, x1) ->
Ast_55.Outcometree.Ocsg_constraint
((copy_out_type x0), (copy_out_type x1))
| Ast_54.Outcometree.Ocsg_method (x0, x1, x2, x3) ->
Ast_55.Outcometree.Ocsg_method (x0, x1, x2, (copy_out_type x3))
| Ast_54.Outcometree.Ocsg_value (x0, x1, x2, x3) ->
Ast_55.Outcometree.Ocsg_value (x0, x1, x2, (copy_out_type x3))
and (copy_out_type_param :
Ast_54.Outcometree.out_type_param -> Ast_55.Outcometree.out_type_param)
=
fun
{ Ast_54.Outcometree.ot_non_gen = ot_non_gen;
Ast_54.Outcometree.ot_name = ot_name;
Ast_54.Outcometree.ot_variance = ot_variance }
->
{
Ast_55.Outcometree.ot_non_gen = ot_non_gen;
Ast_55.Outcometree.ot_name = ot_name;
Ast_55.Outcometree.ot_variance =
(let (x0, x1) = ot_variance in
((copy_variance x0), (copy_injectivity x1)))
}
and (copy_injectivity :
Ast_54.Asttypes.injectivity -> Ast_55.Asttypes.injectivity)
=
function
| Ast_54.Asttypes.Injective -> Ast_55.Asttypes.Injective
| Ast_54.Asttypes.NoInjectivity -> Ast_55.Asttypes.NoInjectivity
and (copy_variance : Ast_54.Asttypes.variance -> Ast_55.Asttypes.variance) =
function
| Ast_54.Asttypes.Covariant -> Ast_55.Asttypes.Covariant
| Ast_54.Asttypes.Contravariant -> Ast_55.Asttypes.Contravariant
| Ast_54.Asttypes.NoVariance -> Ast_55.Asttypes.NoVariance
| Ast_54.Asttypes.Bivariant -> Ast_55.Asttypes.Bivariant
and (copy_out_type :
Ast_54.Outcometree.out_type -> Ast_55.Outcometree.out_type)
=
function
| Ast_54.Outcometree.Otyp_abstract -> Ast_55.Outcometree.Otyp_abstract
| Ast_54.Outcometree.Otyp_open -> Ast_55.Outcometree.Otyp_open
| Ast_54.Outcometree.Otyp_alias {non_gen=x0; aliased=x1; alias=x2} ->
Ast_55.Outcometree.Otyp_alias
{non_gen=x0; aliased=(copy_out_type x1);alias=x2}
| Ast_54.Outcometree.Otyp_arrow (x0, x1, x2) ->
Ast_55.Outcometree.Otyp_arrow
((copy_arg_label x0), (copy_out_type x1), (copy_out_type x2))
| Ast_54.Outcometree.Otyp_class (x0, x1) ->
Ast_55.Outcometree.Otyp_class
((copy_out_ident x0), (List.map (fun x -> copy_out_type x) x1))
| Ast_54.Outcometree.Otyp_constr (x0, x1) ->
Ast_55.Outcometree.Otyp_constr
((copy_out_ident x0), (List.map (fun x -> copy_out_type x) x1))
| Ast_54.Outcometree.Otyp_manifest (x0, x1) ->
Ast_55.Outcometree.Otyp_manifest
((copy_out_type x0), (copy_out_type x1))
| Ast_54.Outcometree.Otyp_object {fields=x0; open_row=x1} ->
Ast_55.Outcometree.Otyp_object
{fields=(List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1)))
x0); row = (if x1 then Orow_open_anonymous else Orow_closed)}
| Ast_54.Outcometree.Otyp_record x0 ->
Ast_55.Outcometree.Otyp_record
(List.map (fun x -> copy_out_label x) x0)
| Ast_54.Outcometree.Otyp_stuff x0 -> Ast_55.Outcometree.Otyp_stuff x0
| Ast_54.Outcometree.Otyp_sum x0 ->
Ast_55.Outcometree.Otyp_sum
(List.map (fun x -> copy_out_constructor x) x0)
| Ast_54.Outcometree.Otyp_tuple x0 ->
Ast_55.Outcometree.Otyp_tuple
(List.map
(fun x ->
let (x0, x1) = x in
((Option.map (fun x -> x) x0), (copy_out_type x1))) x0)
| Ast_54.Outcometree.Otyp_var (x0, x1) ->
Ast_55.Outcometree.Otyp_var (x0, x1)
| Ast_54.Outcometree.Otyp_variant (x0, x1, x2) ->
Ast_55.Outcometree.Otyp_variant
((copy_out_variant x0), x1,
(Option.map (fun x -> List.map (fun x -> x) x) x2))
| Ast_54.Outcometree.Otyp_poly (x0, x1) ->
Ast_55.Outcometree.Otyp_poly
((List.map (fun x -> x) x0), (copy_out_type x1))
| Ast_54.Outcometree.Otyp_module x0 ->
Ast_55.Outcometree.Otyp_module (copy_out_package x0)
| Ast_54.Outcometree.Otyp_attribute (x0, x1) ->
Ast_55.Outcometree.Otyp_attribute
((copy_out_type x0), (copy_out_attribute x1))
and (copy_out_attribute :
Ast_54.Outcometree.out_attribute -> Ast_55.Outcometree.out_attribute)
=
fun { Ast_54.Outcometree.oattr_name = oattr_name } ->
{ Ast_55.Outcometree.oattr_name = oattr_name }
and (copy_out_package :
Ast_54.Outcometree.out_package -> Ast_55.Outcometree.out_package)
=
fun
{ Ast_54.Outcometree.opack_path = opack_path;
Ast_54.Outcometree.opack_cstrs = opack_cstrs }
->
{
Ast_55.Outcometree.opack_path = (copy_out_ident opack_path);
Ast_55.Outcometree.opack_constraints =
(List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1)))
opack_cstrs)
}
and (copy_out_variant :
Ast_54.Outcometree.out_variant -> Ast_55.Outcometree.out_variant)
=
function
| Ast_54.Outcometree.Ovar_fields x0 ->
Ast_55.Outcometree.Ovar_fields
(List.map
(fun x ->
let (x0, x1, x2) = x in
(x0, x1, (List.map (fun x -> copy_out_type x) x2))) x0)
| Ast_54.Outcometree.Ovar_typ x0 ->
Ast_55.Outcometree.Ovar_typ (copy_out_type x0)
and (copy_out_constructor :
Ast_54.Outcometree.out_constructor ->
Ast_55.Outcometree.out_constructor)
=
fun
{ Ast_54.Outcometree.ocstr_name = ocstr_name;
Ast_54.Outcometree.ocstr_args = ocstr_args;
Ast_54.Outcometree.ocstr_return_type = ocstr_return_type }
->
{
Ast_55.Outcometree.ocstr_name = ocstr_name;
Ast_55.Outcometree.ocstr_args =
(List.map (fun x -> copy_out_type x) ocstr_args);
Ast_55.Outcometree.ocstr_return_type =
(Option.map (fun x -> copy_out_type x) ocstr_return_type)
}
and (copy_out_label :
Ast_54.Outcometree.out_label -> Ast_55.Outcometree.out_label)
=
fun
{ Ast_54.Outcometree.olab_name = olab_name;
Ast_54.Outcometree.olab_mut = olab_mut;
Ast_54.Outcometree.olab_atomic = olab_atomic;
Ast_54.Outcometree.olab_type = olab_type }
->
{
Ast_55.Outcometree.olab_name = olab_name;
Ast_55.Outcometree.olab_mut = (copy_mutable_flag olab_mut);
Ast_55.Outcometree.olab_atomic = (copy_atomic_flag olab_atomic);
Ast_55.Outcometree.olab_type = (copy_out_type olab_type)
}
and (copy_atomic_flag :
Ast_54.Asttypes.atomic_flag -> Ast_55.Asttypes.atomic_flag)
=
function
| Ast_54.Asttypes.Nonatomic -> Ast_55.Asttypes.Nonatomic
| Ast_54.Asttypes.Atomic -> Ast_55.Asttypes.Atomic
and (copy_arg_label : Ast_54.Asttypes.arg_label -> Ast_55.Asttypes.arg_label)
=
function
| Ast_54.Asttypes.Nolabel -> Ast_55.Asttypes.Nolabel
| Ast_54.Asttypes.Labelled x0 -> Ast_55.Asttypes.Labelled x0
| Ast_54.Asttypes.Optional x0 -> Ast_55.Asttypes.Optional x0
and (copy_out_value :
Ast_54.Outcometree.out_value -> Ast_55.Outcometree.out_value)
=
function
| Ast_54.Outcometree.Oval_array (x0, x1) ->
Ast_55.Outcometree.Oval_array
((List.map (fun x -> copy_out_value x) x0), (copy_mutable_flag x1))
| Ast_54.Outcometree.Oval_char x0 -> Ast_55.Outcometree.Oval_char x0
| Ast_54.Outcometree.Oval_constr (x0, x1) ->
Ast_55.Outcometree.Oval_constr
((copy_out_ident x0), (List.map (fun x -> copy_out_value x) x1))
| Ast_54.Outcometree.Oval_ellipsis -> Ast_55.Outcometree.Oval_ellipsis
| Ast_54.Outcometree.Oval_float x0 -> Ast_55.Outcometree.Oval_float x0
| Ast_54.Outcometree.Oval_int x0 -> Ast_55.Outcometree.Oval_int x0
| Ast_54.Outcometree.Oval_int32 x0 -> Ast_55.Outcometree.Oval_int32 x0
| Ast_54.Outcometree.Oval_int64 x0 -> Ast_55.Outcometree.Oval_int64 x0
| Ast_54.Outcometree.Oval_nativeint x0 ->
Ast_55.Outcometree.Oval_nativeint x0
| Ast_54.Outcometree.Oval_list x0 ->
Ast_55.Outcometree.Oval_list (List.map (fun x -> copy_out_value x) x0)
| Ast_54.Outcometree.Oval_printer x0 -> Ast_55.Outcometree.Oval_printer x0
| Ast_54.Outcometree.Oval_record x0 ->
Ast_55.Outcometree.Oval_record
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_ident x0), (copy_out_value x1)))
x0)
| Ast_54.Outcometree.Oval_string (x0, x1, x2) ->
Ast_55.Outcometree.Oval_string (x0, x1, (copy_out_string x2))
| Ast_54.Outcometree.Oval_stuff x0 -> Ast_55.Outcometree.Oval_stuff x0
| Ast_54.Outcometree.Oval_tuple x0 ->
Ast_55.Outcometree.Oval_tuple
(List.map
(fun x ->
let (x0, x1) = x in
((Option.map (fun x -> x) x0), (copy_out_value x1))) x0)
| Ast_54.Outcometree.Oval_variant (x0, x1) ->
Ast_55.Outcometree.Oval_variant
(x0, (Option.map (fun x -> copy_out_value x) x1))
| Ast_54.Outcometree.Oval_lazy x0 ->
Ast_55.Outcometree.Oval_lazy (copy_out_value x0)
| Ast_54.Outcometree.Oval_floatarray x0 ->
Ast_55.Outcometree.Oval_floatarray
(Float.Array.map (fun x -> x) x0)
and (copy_out_string :
Ast_54.Outcometree.out_string -> Ast_55.Outcometree.out_string)
=
function
| Ast_54.Outcometree.Ostr_string -> Ast_55.Outcometree.Ostr_string
| Ast_54.Outcometree.Ostr_bytes -> Ast_55.Outcometree.Ostr_bytes
and (copy_out_ident :
Ast_54.Outcometree.out_ident -> Ast_55.Outcometree.out_ident)
=
function
| Ast_54.Outcometree.Oide_apply (x0, x1) ->
Ast_55.Outcometree.Oide_apply
((copy_out_ident x0), (copy_out_ident x1))
| Ast_54.Outcometree.Oide_dot (x0, x1) ->
Ast_55.Outcometree.Oide_dot ((copy_out_ident x0), x1)
| Ast_54.Outcometree.Oide_ident x0 ->
Ast_55.Outcometree.Oide_ident (copy_out_name x0)
and (copy_out_name :
Ast_54.Outcometree.out_name -> Ast_55.Outcometree.out_name)
=
fun { Ast_54.Outcometree.printed_name = printed_name } ->
{ Ast_55.Outcometree.printed_name = printed_name }
and (copy_mutable_flag :
Ast_54.Asttypes.mutable_flag -> Ast_55.Asttypes.mutable_flag)
=
function
| Ast_54.Asttypes.Immutable -> Ast_55.Asttypes.Immutable
| Ast_54.Asttypes.Mutable -> Ast_55.Asttypes.Mutable
================================================
FILE: src/vendored-omp/src/migrate_parsetree_55_54.ml
================================================
include Migrate_parsetree_55_54_migrate
================================================
FILE: src/vendored-omp/src/migrate_parsetree_55_54_migrate.ml
================================================
module From = Ast_55
module To = Ast_54
let rec (copy_out_type_extension :
Ast_55.Outcometree.out_type_extension ->
Ast_54.Outcometree.out_type_extension)
=
fun
{ Ast_55.Outcometree.otyext_name = otyext_name;
Ast_55.Outcometree.otyext_params = otyext_params;
Ast_55.Outcometree.otyext_constructors = otyext_constructors;
Ast_55.Outcometree.otyext_private = otyext_private }
->
{
Ast_54.Outcometree.otyext_name = otyext_name;
Ast_54.Outcometree.otyext_params =
(List.map (fun x -> x.Ast_55.Outcometree.ot_name) otyext_params);
Ast_54.Outcometree.otyext_constructors =
(List.map (fun x -> copy_out_constructor x) otyext_constructors);
Ast_54.Outcometree.otyext_private = (copy_private_flag otyext_private)
}
and (copy_out_phrase :
Ast_55.Outcometree.out_phrase -> Ast_54.Outcometree.out_phrase)
=
function
| Ast_55.Outcometree.Ophr_eval (x0, x1) ->
Ast_54.Outcometree.Ophr_eval ((copy_out_value x0), (copy_out_type x1))
| Ast_55.Outcometree.Ophr_signature x0 ->
Ast_54.Outcometree.Ophr_signature
(List.map
(fun x ->
let (x0, x1) = x in
((copy_out_sig_item x0),
(Option.map (fun x -> copy_out_value x) x1))) x0)
| Ast_55.Outcometree.Ophr_exception x0 ->
Ast_54.Outcometree.Ophr_exception
(let (x0, x1) = x0 in (x0, (copy_out_value x1)))
and (copy_out_sig_item :
Ast_55.Outcometree.out_sig_item -> Ast_54.Outcometree.out_sig_item)
=
function
| Ast_55.Outcometree.Osig_class (x0, x1, x2, x3, x4) ->
Ast_54.Outcometree.Osig_class
(x0, x1, (List.map (fun x -> copy_out_type_param x) x2),
(copy_out_class_type x3), (copy_out_rec_status x4))
| Ast_55.Outcometree.Osig_class_type (x0, x1, x2, x3, x4) ->
Ast_54.Outcometree.Osig_class_type
(x0, x1, (List.map (fun x -> copy_out_type_param x) x2),
(copy_out_class_type x3), (copy_out_rec_status x4))
| Ast_55.Outcometree.Osig_typext (x0, x1) ->
Ast_54.Outcometree.Osig_typext
((copy_out_extension_constructor x0), (copy_out_ext_status x1))
| Ast_55.Outcometree.Osig_modtype (x0, x1) ->
Ast_54.Outcometree.Osig_modtype (x0, (copy_out_module_type x1))
| Ast_55.Outcometree.Osig_module (x0, x1, x2) ->
Ast_54.Outcometree.Osig_module
(x0, (copy_out_module_type x1), (copy_out_rec_status x2))
| Ast_55.Outcometree.Osig_type (x0, x1) ->
Ast_54.Outcometree.Osig_type
((copy_out_type_decl x0), (copy_out_rec_status x1))
| Ast_55.Outcometree.Osig_value x0 ->
Ast_54.Outcometree.Osig_value (copy_out_val_decl x0)
| Ast_55.Outcometree.Osig_ellipsis -> Ast_54.Outcometree.Osig_ellipsis
and (copy_out_val_decl :
Ast_55.Outcometree.out_val_decl -> Ast_54.Outcometree.out_val_decl)
=
fun
{ Ast_55.Outcometree.oval_name = oval_name;
Ast_55.Outcometree.oval_type = oval_type;
Ast_55.Outcometree.oval_prims = oval_prims;
Ast_55.Outcometree.oval_attributes = oval_attributes }
->
{
Ast_54.Outcometree.oval_name = oval_name;
Ast_54.Outcometree.oval_type = (copy_out_type oval_type);
Ast_54.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims);
Ast_54.Outcometree.oval_attributes =
(List.map (fun x -> copy_out_attribute x) oval_attributes)
}
and (copy_out_type_decl :
Ast_55.Outcometree.out_type_decl -> Ast_54.Outcometree.out_type_decl)
=
fun
{ Ast_55.Outcometree.otype_name = otype_name;
Ast_55.Outcometree.otype_params = otype_params;
Ast_55.Outcometree.otype_type = otype_type;
Ast_55.Outcometree.otype_private = otype_private;
Ast_55.Outcometree.otype_immediate = otype_immediate;
Ast_55.Outcometree.otype_unboxed = otype_unboxed;
Ast_55.Outcometree.otype_constraints = otype_constraints }
->
{
Ast_54.Outcometree.otype_name = otype_name;
Ast_54.Outcometree.otype_params =
(List.map (fun x -> copy_out_type_param x) otype_params);
Ast_54.Outcometree.otype_type = (copy_out_type otype_type);
Ast_54.Outcometree.otype_private = (copy_private_flag otype_private);
Ast_54.Outcometree.otype_immediate =
(copy_Type_immediacy_t otype_immediate);
Ast_54.Outcometree.otype_unboxed = otype_unboxed;
Ast_54.Outcometree.otype_cstrs =
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_type x0), (copy_out_type x1)))
otype_constraints)
}
and (copy_Type_immediacy_t :
Ast_55.Type_immediacy.t -> Ast_54.Type_immediacy.t)
=
function
| Ast_55.Type_immediacy.Unknown -> Ast_54.Type_immediacy.Unknown
| Ast_55.Type_immediacy.Always -> Ast_54.Type_immediacy.Always
| Ast_55.Type_immediacy.Always_on_64bits ->
Ast_54.Type_immediacy.Always_on_64bits
and (copy_out_module_type :
Ast_55.Outcometree.out_module_type ->
Ast_54.Outcometree.out_module_type)
=
function
| Ast_55.Outcometree.Omty_abstract -> Ast_54.Outcometree.Omty_abstract
| Ast_55.Outcometree.Omty_functor (x0, x1) ->
Ast_54.Outcometree.Omty_functor
((Option.map
(fun x ->
let (x0, x1) = x in
((Option.map (fun x -> x) x0), (copy_out_module_type x1))) x0),
(copy_out_module_type x1))
| Ast_55.Outcometree.Omty_ident x0 ->
Ast_54.Outcometree.Omty_ident (copy_out_ident x0)
| Ast_55.Outcometree.Omty_signature x0 ->
Ast_54.Outcometree.Omty_signature
(List.map (fun x -> copy_out_sig_item x) x0)
| Ast_55.Outcometree.Omty_alias x0 ->
Ast_54.Outcometree.Omty_alias (copy_out_ident x0)
and (copy_out_ext_status :
Ast_55.Outcometree.out_ext_status -> Ast_54.Outcometree.out_ext_status)
=
function
| Ast_55.Outcometree.Oext_first -> Ast_54.Outcometree.Oext_first
| Ast_55.Outcometree.Oext_next -> Ast_54.Outcometree.Oext_next
| Ast_55.Outcometree.Oext_exception -> Ast_54.Outcometree.Oext_exception
and (copy_out_extension_constructor :
Ast_55.Outcometree.out_extension_constructor ->
Ast_54.Outcometree.out_extension_constructor)
=
fun
{ Ast_55.Outcometree.oext_name = oext_name;
Ast_55.Outcometree.oext_type_name = oext_type_name;
Ast_55.Outcometree.oext_type_params = oext_type_params;
Ast_55.Outcometree.oext_args = oext_args;
Ast_55.Outcometree.oext_ret_type = oext_ret_type;
Ast_55.Outcometree.oext_private = oext_private }
->
{
Ast_54.Outcometree.oext_name = oext_name;
Ast_54.Outcometree.oext_type_name = oext_type_name;
Ast_54.Outcometree.oext_type_params =
(List.map (fun x -> x.Ast_55.Outcometree.ot_name) oext_type_params);
Ast_54.Outcometree.oext_args =
(List.map (fun x -> copy_out_type x) oext_args);
Ast_54.Outcometree.oext_ret_type =
(Option.map (fun x -> copy_out_type x) oext_ret_type);
Ast_54.Outcometree.oext_private = (copy_private_flag oext_private)
}
and (copy_private_flag :
Ast_55.Asttypes.private_flag -> Ast_54.Asttypes.private_flag)
=
function
| Ast_55.Asttypes.Private -> Ast_54.Asttypes.Private
| Ast_55.Asttypes.Public -> Ast_54.Asttypes.Public
and (copy_out_rec_status :
Ast_55.Outcometree.out_rec_status -> Ast_54.Outcometree.out_rec_status)
=
function
| Ast_55.Outcometree.Orec_not -> Ast_54.Outcometree.Orec_not
| Ast_55.Outcometree.Orec_first -> Ast_54.Outcometree.Orec_first
| Ast_55.Outcometree.Orec_next -> Ast_54.Outcometree.Orec_next
and (copy_out_class_type :
Ast_55.Outcometree.out_class_type -> Ast_54.Outcometree.out_class_type)
=
function
| Ast_55.Outcometree.Octy_constr (x0, x1) ->
Ast_54.Outcometree.Octy_constr
((copy_out_ident x0), (List.map (fun x -> copy_out_type x) x1))
| Ast_55.Outcometree.Octy_arrow (x0, x1, x2) ->
Ast_54.Outcometree.Octy_arrow
((copy_arg_label x0), (copy_out_type x1), (copy_out_class_type x2))
| Ast_55.Outcometree.Octy_signature (x0, x1) ->
Ast_54.Outcometree.Octy_signature
((Option.map (fun x -> copy_out_type x) x0),
(List.map (fun x -> copy_out_class_sig_item x) x1))
and (copy_out_class_sig_item :
Ast_55.Outcometree.out_class_sig_item ->
Ast_54.Outcometree.out_class_sig_item)
=
function
| Ast_55.Outcometree.Ocsg_constraint (x0, x1) ->
Ast_54.Outcometree.Ocsg_constraint
((copy_out_type x0), (copy_out_type x1))
| Ast_55.Outcometree.Ocsg_method (x0, x1, x2, x3) ->
Ast_54.Outcometree.Ocsg_method (x0, x1, x2, (copy_out_type x3))
| Ast_55.Outcometree.Ocsg_value (x0, x1, x2, x3) ->
Ast_54.Outcometree.Ocsg_value (x0, x1, x2, (copy_out_type x3))
and (copy_out_type_param :
Ast_55.Outcometree.out_type_param -> Ast_54.Outcometree.out_type_param)
=
fun
{ Ast_55.Outcometree.ot_non_gen = ot_non_gen;
Ast_55.Outcometree.ot_name = ot_name;
Ast_55.Outcometree.ot_variance = ot_variance }
->
{
Ast_54.Outcometree.ot_non_gen = ot_non_gen;
Ast_54.Outcometree.ot_name = ot_name;
Ast_54.Outcometree.ot_variance =
(let (x0, x1) = ot_variance in
((copy_variance x0), (copy_injectivity x1)))
}
and (copy_injectivity :
Ast_55.Asttypes.injectivity -> Ast_54.Asttypes.injectivity)
=
function
| Ast_55.Asttypes.Injective -> Ast_54.Asttypes.Injective
| Ast_55.Asttypes.NoInjectivity -> Ast_54.Asttypes.NoInjectivity
and (copy_variance : Ast_55.Asttypes.variance -> Ast_54.Asttypes.variance) =
function
| Ast_55.Asttypes.Covariant -> Ast_54.Asttypes.Covariant
| Ast_55.Asttypes.Contravariant -> Ast_54.Asttypes.Contravariant
| Ast_55.Asttypes.NoVariance -> Ast_54.Asttypes.NoVariance
| Ast_55.Asttypes.Bivariant -> Ast_54.Asttypes.Bivariant
and (copy_out_type :
Ast_55.Outcometree.out_type -> Ast_54.Outcometree.out_type)
=
function
| Ast_55.Outcometree.Otyp_abstract -> Ast_54.Outcometree.Otyp_abstract
| Ast_55.Outcometree.Otyp_open -> Ast_54.Outcometree.Otyp_open
| Ast_55.Outcometree.Otyp_alias {non_gen=x0; aliased=x1; alias=x2} ->
Ast_54.Outcometree.Otyp_alias
{non_gen=x0; aliased=(copy_out_type x1);alias=x2}
| Ast_55.Outcometree.Otyp_arrow (x0, x1, x2) ->
Ast_54.Outcometree.Otyp_arrow
((copy_arg_label x0), (copy_out_type x1), (copy_out_type x2))
| Ast_55.Outcometree.Otyp_class (x0, x1) ->
Ast_54.Outcometree.Otyp_class
((copy_out_ident x0), (List.map (fun x -> copy_out_type x) x1))
| Ast_55.Outcometree.Otyp_constr (x0, x1) ->
Ast_54.Outcometree.Otyp_constr
((copy_out_ident x0), (List.map (fun x -> copy_out_type x) x1))
| Ast_55.Outcometree.Otyp_manifest (x0, x1) ->
Ast_54.Outcometree.Otyp_manifest
((copy_out_type x0), (copy_out_type x1))
| Ast_55.Outcometree.Otyp_object {fields=x0; row=x1} ->
Ast_54.Outcometree.Otyp_object
{fields=(List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1)))
x0);open_row= (copy_out_row x1)}
| Ast_55.Outcometree.Otyp_record x0 ->
Ast_54.Outcometree.Otyp_record
(List.map (fun x -> copy_out_label x) x0)
| Ast_55.Outcometree.Otyp_stuff x0 -> Ast_54.Outcometree.Otyp_stuff x0
| Ast_55.Outcometree.Otyp_sum x0 ->
Ast_54.Outcometree.Otyp_sum
(List.map (fun x -> copy_out_constructor x) x0)
| Ast_55.Outcometree.Otyp_tuple x0 ->
Ast_54.Outcometree.Otyp_tuple
(List.map
(fun x ->
let (x0, x1) = x in
((Option.map (fun x -> x) x0), (copy_out_type x1))) x0)
| Ast_55.Outcometree.Otyp_var (x0, x1) ->
Ast_54.Outcometree.Otyp_var (x0, x1)
| Ast_55.Outcometree.Otyp_variant (x0, x1, x2) ->
Ast_54.Outcometree.Otyp_variant
((copy_out_variant x0), x1,
(Option.map (fun x -> List.map (fun x -> x) x) x2))
| Ast_55.Outcometree.Otyp_poly (x0, x1) ->
Ast_54.Outcometree.Otyp_poly
((List.map (fun x -> x) x0), (copy_out_type x1))
| Ast_55.Outcometree.Otyp_module x0 ->
Ast_54.Outcometree.Otyp_module (copy_out_package x0)
| Ast_55.Outcometree.Otyp_attribute (x0, x1) ->
Ast_54.Outcometree.Otyp_attribute
((copy_out_type x0), (copy_out_attribute x1))
| Ast_55.Outcometree.Otyp_external _x0 ->
Ast_54.Outcometree.Otyp_abstract
| Ast_55.Outcometree.Otyp_functor _ -> Ast_54.Outcometree.Otyp_abstract
and (copy_out_attribute :
Ast_55.Outcometree.out_attribute -> Ast_54.Outcometree.out_attribute)
=
fun { Ast_55.Outcometree.oattr_name = oattr_name } ->
{ Ast_54.Outcometree.oattr_name = oattr_name }
and (copy_out_package :
Ast_55.Outcometree.out_package -> Ast_54.Outcometree.out_package)
=
fun
{ Ast_55.Outcometree.opack_path = opack_path;
Ast_55.Outcometree.opack_constraints = opack_constraints }
->
{
Ast_54.Outcometree.opack_path = (copy_out_ident opack_path);
Ast_54.Outcometree.opack_cstrs =
(List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1)))
opack_constraints)
}
and (copy_out_variant :
Ast_55.Outcometree.out_variant -> Ast_54.Outcometree.out_variant)
=
function
| Ast_55.Outcometree.Ovar_fields x0 ->
Ast_54.Outcometree.Ovar_fields
(List.map
(fun x ->
let (x0, x1, x2) = x in
(x0, x1, (List.map (fun x -> copy_out_type x) x2))) x0)
| Ast_55.Outcometree.Ovar_typ x0 ->
Ast_54.Outcometree.Ovar_typ (copy_out_type x0)
and (copy_out_constructor :
Ast_55.Outcometree.out_constructor ->
Ast_54.Outcometree.out_constructor)
=
fun
{ Ast_55.Outcometree.ocstr_name = ocstr_name;
Ast_55.Outcometree.ocstr_args = ocstr_args;
Ast_55.Outcometree.ocstr_return_type = ocstr_return_type }
->
{
Ast_54.Outcometree.ocstr_name = ocstr_name;
Ast_54.Outcometree.ocstr_args =
(List.map (fun x -> copy_out_type x) ocstr_args);
Ast_54.Outcometree.ocstr_return_type =
(Option.map (fun x -> copy_out_type x) ocstr_return_type)
}
and (copy_out_label :
Ast_55.Outcometree.out_label -> Ast_54.Outcometree.out_label)
=
fun
{ Ast_55.Outcometree.olab_name = olab_name;
Ast_55.Outcometree.olab_mut = olab_mut;
Ast_55.Outcometree.olab_atomic = olab_atomic;
Ast_55.Outcometree.olab_type = olab_type }
->
{
Ast_54.Outcometree.olab_name = olab_name;
Ast_54.Outcometree.olab_mut = (copy_mutable_flag olab_mut);
Ast_54.Outcometree.olab_atomic = (copy_atomic_flag olab_atomic);
Ast_54.Outcometree.olab_type = (copy_out_type olab_type)
}
and (copy_atomic_flag :
Ast_55.Asttypes.atomic_flag -> Ast_54.Asttypes.atomic_flag)
=
function
| Ast_55.Asttypes.Nonatomic -> Ast_54.Asttypes.Nonatomic
| Ast_55.Asttypes.Atomic -> Ast_54.Asttypes.Atomic
and (copy_out_row : Ast_55.Outcometree.out_row -> bool)
=
function
| Ast_55.Outcometree.Orow_closed -> false
| Ast_55.Outcometree.Orow_open_anonymous
| Ast_55.Outcometree.Orow_open _ -> true
and (copy_arg_label : Ast_55.Asttypes.arg_label -> Ast_54.Asttypes.arg_label)
=
function
| Ast_55.Asttypes.Nolabel -> Ast_54.Asttypes.Nolabel
| Ast_55.Asttypes.Labelled x0 -> Ast_54.Asttypes.Labelled x0
| Ast_55.Asttypes.Optional x0 -> Ast_54.Asttypes.Optional x0
and (copy_out_value :
Ast_55.Outcometree.out_value -> Ast_54.Outcometree.out_value)
=
function
| Ast_55.Outcometree.Oval_array (x0, x1) ->
Ast_54.Outcometree.Oval_array
((List.map (fun x -> copy_out_value x) x0), (copy_mutable_flag x1))
| Ast_55.Outcometree.Oval_char x0 -> Ast_54.Outcometree.Oval_char x0
| Ast_55.Outcometree.Oval_constr (x0, x1) ->
Ast_54.Outcometree.Oval_constr
((copy_out_ident x0), (List.map (fun x -> copy_out_value x) x1))
| Ast_55.Outcometree.Oval_ellipsis -> Ast_54.Outcometree.Oval_ellipsis
| Ast_55.Outcometree.Oval_float x0 -> Ast_54.Outcometree.Oval_float x0
| Ast_55.Outcometree.Oval_int x0 -> Ast_54.Outcometree.Oval_int x0
| Ast_55.Outcometree.Oval_int32 x0 -> Ast_54.Outcometree.Oval_int32 x0
| Ast_55.Outcometree.Oval_int64 x0 -> Ast_54.Outcometree.Oval_int64 x0
| Ast_55.Outcometree.Oval_nativeint x0 ->
Ast_54.Outcometree.Oval_nativeint x0
| Ast_55.Outcometree.Oval_list x0 ->
Ast_54.Outcometree.Oval_list (List.map (fun x -> copy_out_value x) x0)
| Ast_55.Outcometree.Oval_printer x0 -> Ast_54.Outcometree.Oval_printer x0
| Ast_55.Outcometree.Oval_record x0 ->
Ast_54.Outcometree.Oval_record
(List.map
(fun x ->
let (x0, x1) = x in ((copy_out_ident x0), (copy_out_value x1)))
x0)
| Ast_55.Outcometree.Oval_string (x0, x1, x2) ->
Ast_54.Outcometree.Oval_string (x0, x1, (copy_out_string x2))
| Ast_55.Outcometree.Oval_stuff x0 -> Ast_54.Outcometree.Oval_stuff x0
| Ast_55.Outcometree.Oval_tuple x0 ->
Ast_54.Outcometree.Oval_tuple
(List.map
(fun x ->
let (x0, x1) = x in
((Option.map (fun x -> x) x0), (copy_out_value x1))) x0)
| Ast_55.Outcometree.Oval_variant (x0, x1) ->
Ast_54.Outcometree.Oval_variant
(x0, (Option.map (fun x -> copy_out_value x) x1))
| Ast_55.Outcometree.Oval_lazy x0 ->
Ast_54.Outcometree.Oval_lazy (copy_out_value x0)
| Ast_55.Outcometree.Oval_floatarray x0 ->
Ast_54.Outcometree.Oval_floatarray
(Float.Array.map (fun x -> x) x0)
and (copy_out_string :
Ast_55.Outcometree.out_string -> Ast_54.Outcometree.out_string)
=
function
| Ast_55.Outcometree.Ostr_string -> Ast_54.Outcometree.Ostr_string
| Ast_55.Outcometree.Ostr_bytes -> Ast_54.Outcometree.Ostr_bytes
and (copy_out_ident :
Ast_55.Outcometree.out_ident -> Ast_54.Outcometree.out_ident)
=
function
| Ast_55.Outcometree.Oide_apply (x0, x1) ->
Ast_54.Outcometree.Oide_apply
((copy_out_ident x0), (copy_out_ident x1))
| Ast_55.Outcometree.Oide_dot (x0, x1) ->
Ast_54.Outcometree.Oide_dot ((copy_out_ident x0), x1)
| Ast_55.Outcometree.Oide_ident x0 ->
Ast_54.Outcometree.Oide_ident (copy_out_name x0)
and (copy_out_name :
Ast_55.Outcometree.out_name -> Ast_54.Outcometree.out_name)
=
fun { Ast_55.Outcometree.printed_name = printed_name } ->
{ Ast_54.Outcometree.printed_name = printed_name }
and (copy_mutable_flag :
Ast_55.Asttypes.mutable_flag -> Ast_54.Asttypes.mutable_flag)
=
function
| Ast_55.Asttypes.Immutable -> Ast_54.Asttypes.Immutable
| Ast_55.Asttypes.Mutable -> Ast_54.Asttypes.Mutable
================================================
FILE: src/vendored-omp/src/migrate_parsetree_def.ml
================================================
(**************************************************************************)
(* *)
(* OCaml Migrate Parsetree *)
(* *)
(* Frédéric Bour *)
(* *)
(* Copyright 2017 Institut National de Recherche en Informatique et *)
(* en Automatique (INRIA). *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
(** Errors that can happen when converting constructions that doesn't exist in
older version of the AST. *)
type missing_feature =
| Pexp_letexception
(** 4.04 -> 4.03: local exception, let exception _ in ... *)
| Ppat_open
(** 4.04 -> 4.03: module open in pattern match x with M.(_) -> ... *)
| Pexp_unreachable
(** 4.04 -> 4.03: unreachable pattern -> . *)
| PSig
(** 4.03 -> 4.02: signature in attribute, [@: val x : int] *)
| Pcstr_record
(** 4.03 -> 4.02: inline record *)
| Pconst_integer
(** 4.03 -> 4.02: integer literal with invalid suffix, 1234d *)
| Pconst_float
(** 4.03 -> 4.02: float literal with invalid suffix, 1234.0g *)
| Pcl_open
(** 4.06 -> 4.05: let open M in <class-expression> *)
| Pcty_open
(** 4.06 -> 4.05: let open M in <class-type> *)
| Oinherit
(** 4.06 -> 4.05: type t = < m : int; u > *)
| Pwith_typesubst_longident
(** 4.06 -> 4.05: T with type X.t := ... *)
| Pwith_modsubst_longident
(** 4.06 -> 4.05: T with module X.Y := ... *)
| Pexp_open
(** 4.08 -> 4.07: open M(N).O *)
| Pexp_letop
(** 4.08 -> 4.07: let* x = ... *)
| Psig_typesubst
(** 4.08 -> 4.07: type t := ... *)
| Psig_modsubst
(** 4.08 -> 4.07: module M := ... *)
| Otyp_module
(** 4.08 -> 4.07: M(N) *)
| Immediate64
(** 4.10 -> 4.09: [@@immediate64] *)
| Anonymous_let_module
(** 4.10 -> 4.09: let module _ = ... in ... *)
| Anonymous_unpack
(** 4.10 -> 4.09: (module _) *)
| Anonymous_module_binding
(** 4.10 -> 4.09: module _ = ... *)
| Anonymous_module_declaration
(** 4.10 -> 4.09: module _ = struct ... end *)
| ExistentialsInPatternMatching
(** 4.13 -> 4.12: match ... with Cstr (type a) (x, y : int * a) -> ... *)
| With_modtype
(** 4.13 -> 4.12: M with module type N = O *)
| With_modtypesubst
(** 4.13 -> 4.12: M with module type N := O *)
| Psig_modtypesubst
(** 4.13 -> 4.12: module M := sig ... end *)
| Extension_constructor
(** 4.14 -> 4.13: C: 'a... . T1... -> T0 *)
| Pcd_vars
(** 4.14 -> 4.13: 'a1 ... 'an. T *)
exception Migration_error of missing_feature * Location.t
(** [missing_feature_description x] is a text describing the feature [x]. *)
let missing_feature_description = function
| Pexp_letexception -> "local exceptions"
| Ppat_open -> "module open in patterns"
| Pexp_unreachable -> "unreachable patterns"
| PSig -> "signatures in attribute"
| Pcstr_record -> "inline records"
| Pconst_integer -> "custom integer literals"
| Pconst_float -> "custom float literals"
| Pcl_open -> "module open in class expression"
| Pcty_open -> "module open in class type"
| Oinherit -> "inheritance in object type"
| Pwith_typesubst_longident -> "type substitution inside a submodule"
| Pwith_modsubst_longident -> "module substitution inside a submodule"
| Pexp_open -> "complex open"
| Pexp_letop -> "let operators"
| Psig_typesubst -> "type substitution in signatures"
| Psig_modsubst -> "module substitution in signatures"
| Otyp_module -> "complex outcome module"
| Immediate64 -> "[@@immediate64] attribute"
| Anonymous_let_module -> "anonymous let module"
| Anonymous_unpack -> "anynymous unpack"
| Anonymous_module_binding -> "anonymous module binding"
| Anonymous_module_declaration -> "anonymous module declaration"
| ExistentialsInPatternMatching -> "existentials in pattern-matching"
| With_modtype -> "module type substitution"
| With_modtypesubst -> "destructive module type substitution"
| Psig_modtypesubst -> "local module type substitution"
| Extension_constructor -> "type parameters in extension constructors"
| Pcd_vars -> "pcd_vars in constructor declarations"
(** [missing_feature_minimal_version x] is the OCaml version where x was
introduced. *)
let missing_feature_minimal_version = function
| Pexp_letexception -> "OCaml 4.04"
| Ppat_open -> "OCaml 4.04"
| Pexp_unreachable -> "OCaml 4.03"
| PSig -> "OCaml 4.03"
| Pcstr_record -> "OCaml 4.03"
| Pconst_integer -> "OCaml 4.03"
| Pconst_float -> "OCaml 4.03"
| Pcl_open -> "OCaml 4.06"
| Pcty_open -> "OCaml 4.06"
| Oinherit -> "OCaml 4.06"
| Pwith_typesubst_longident -> "OCaml 4.06"
| Pwith_modsubst_longident -> "OCaml 4.06"
| Pexp_open -> "OCaml 4.08"
| Pexp_letop -> "OCaml 4.08"
| Psig_typesubst -> "OCaml 4.08"
| Psig_modsubst -> "OCaml 4.08"
| Otyp_module -> "OCaml 4.08"
| Immediate64 -> "OCaml 4.10"
| Anonymous_let_module -> "OCaml 4.10"
| Anonymous_unpack -> "OCaml 4.10"
| Anonymous_module_binding -> "OCaml 4.10"
| Anonymous_module_declaration -> "OCaml 4.10"
| ExistentialsInPatternMatching -> "OCaml 4.13"
| With_modtype -> "OCaml 4.13"
| With_modtypesubst -> "OCaml 4.13"
| Psig_modtypesubst -> "OCaml 4.13"
| Extension_constructor -> "OCaml 4.14"
| Pcd_vars -> "OCaml 4.14"
(** Turn a missing feature into a reasonable error message. *)
let migration_error_message x =
let feature = missing_feature_description x in
let version = missing_feature_minimal_version x in
feature ^ " are not supported before " ^ version
let () =
let location_prefix l =
if l = Location.none then "" else
let {Location.loc_start; loc_end; _} = l in
let bol = loc_start.Lexing.pos_bol in
Printf.sprintf "File %S, line %d, characters %d-%d: "
loc_start.Lexing.pos_fname
loc_start.Lexing.pos_lnum
(loc_start.Lexing.pos_cnum - bol)
(loc_end.Lexing.pos_cnum - bol)
in
Printexc.register_printer (function
| Migration_error (err, loc) ->
Some (location_prefix loc ^ migration_error_message err)
| _ -> None
)
================================================
FILE: src/vendored-omp/src/migrate_parsetree_def.mli
================================================
(**************************************************************************)
(* *)
(* OCaml Migrate Parsetree *)
(* *)
(* Frédéric Bour *)
(* *)
(* Copyright 2017 Institut National de Recherche en Informatique et *)
(* en Automatique (INRIA). *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
(** Features which are not available in all versions of the frontend *)
type missing_feature =
Pexp_letexception
| Ppat_open
| Pexp_unreachable
| PSig
| Pcstr_record
| Pconst_integer
| Pconst_float
| Pcl_open
| Pcty_open
| Oinherit
| Pwith_typesubst_longident
| Pwith_modsubst_longident
| Pexp_open
| Pexp_letop
| Psig_typesubst
| Psig_modsubst
| Otyp_module
| Immediate64
| Anonymous_let_module
| Anonymous_unpack
| Anonymous_module_binding
| Anonymous_module_declaration
| ExistentialsInPatternMatching
| With_modtype
| With_modtypesubst
| Psig_modtypesubst
| Extension_constructor
| Pcd_vars
(** Exception thrown by migration functions when a feature is not supported. *)
exception Migration_error of missing_feature * Location.t
(** [missing_feature_description x] is a text describing the feature [x]. *)
val missing_feature_description : missing_feature -> string
(** [missing_feature_minimal_version x] is the OCaml version where x was
introduced. *)
val missing_feature_minimal_version : missing_feature -> string
(** Turn a missing feature into a reasonable error message. *)
val migration_error_message : missing_feature -> string
================================================
FILE: src/vendored-omp/src/migrate_parsetree_driver_main.ml
================================================
let () = Reason_omp.Driver.run_main ()
================================================
FILE: src/vendored-omp/src/migrate_parsetree_versions.ml
================================================
(**************************************************************************)
(* *)
(* OCaml Migrate Parsetree *)
(* *)
(* Frédéric Bour *)
(* Jérémie Dimino, Jane Street Europe *)
(* *)
(* Copyright 2017 Institut National de Recherche en Informatique et *)
(* en Automatique (INRIA). *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
(* BEGIN of BLACK MAGIC *)
(*$ #use "src/cinaps_helpers" $*)
type _ witnesses = ..
type _ migration = ..
type _ migration += Undefined : _ migration
type 'a migration_info = {
mutable next_version : 'a migration;
mutable previous_version : 'a migration;
}
(** Abstract view of a version of an OCaml Ast *)
module type Ast = sig
(*$ foreach_module (fun m types ->
printf "module %s : sig\n" m;
List.iter types ~f:(printf "type %s\n");
printf "end\n"
)
*)
module Outcometree : sig
type out_value
type out_type
type out_class_type
type out_module_type
type out_sig_item
type out_type_extension
type out_phrase
end
(*$*)
end
(* Shortcuts for talking about ast types outside of the module language *)
type 'a _types = 'a constraint 'a
= <
(*$ foreach_type (fun _ s -> printf "%-21s : _;\n" s) *)
out_value : _;
out_type : _;
out_class_type : _;
out_module_type : _;
out_sig_item : _;
out_type_extension : _;
out_phrase : _;
(*$*)
>
;;
(*$ foreach_type (fun _ s ->
printf "type 'a get_%s =\n" s;
printf " 'x constraint 'a _types = < %s : 'x; .. >\n" s
) *)
type 'a get_out_value =
'x constraint 'a _types = < out_value : 'x; .. >
type 'a get_out_type =
'x constraint 'a _types = < out_type : 'x; .. >
type 'a get_out_class_type =
'x constraint 'a _types = < out_class_type : 'x; .. >
type 'a get_out_module_type =
'x constraint 'a _types = < out_module_type : 'x; .. >
type 'a get_out_sig_item =
'x constraint 'a _types = < out_sig_item : 'x; .. >
type 'a get_out_type_extension =
'x constraint 'a _types = < out_type_extension : 'x; .. >
type 'a get_out_phrase =
'x constraint 'a _types = < out_phrase : 'x; .. >
(*$*)
module type OCaml_version = sig
module Ast : Ast
val version : int
val string_version : string
type types = <
(*$ foreach_type (fun m s -> printf "%-21s : Ast.%s.%s;\n" s m s)*)
out_value : Ast.Outcometree.out_value;
out_type : Ast.Outcometree.out_type;
out_class_type : Ast.Outcometree.out_class_type;
out_module_type : Ast.Outcometree.out_module_type;
out_sig_item : Ast.Outcometree.out_sig_item;
out_type_extension : Ast.Outcometree.out_type_extension;
out_phrase : Ast.Outcometree.out_phrase;
(*$*)
> _types
type _ witnesses += Version : types witnesses
val migration_info : types migration_info
end
module Make_witness(Ast : Ast) =
struct
type types = <
(*$ foreach_type (fun m s -> printf "%-21s : Ast.%s.%s;\n" s m s)*)
out_value : Ast.Outcometree.out_value;
out_type : Ast.Outcometree.out_type;
out_class_type : Ast.Outcometree.out_class_type;
out_module_type : Ast.Outcometree.out_module_type;
out_sig_item : Ast.Outcometree.out_sig_item;
out_type_extension : Ast.Outcometree.out_type_extension;
out_phrase : Ast.Outcometree.out_phrase;
(*$*)
> _types
type _ witnesses += Version : types witnesses
let migration_info : types migration_info =
{ next_version = Undefined; previous_version = Undefined }
end
type 'types ocaml_version =
(module OCaml_version
(*$ let sep = with_then_and () in
foreach_type (fun m s ->
printf "%t type Ast.%s.%s = 'types get_%s\n" sep m s s) *)
with type Ast.Outcometree.out_value = 'types get_out_value
and type Ast.Outcometree.out_type = 'types get_out_type
and type Ast.Outcometree.out_class_type = 'types get_out_class_type
and type Ast.Outcometree.out_module_type = 'types get_out_module_type
and type Ast.Outcometree.out_sig_item = 'types get_out_sig_item
and type Ast.Outcometree.out_type_extension = 'types get_out_type_extension
and type Ast.Outcometree.out_phrase = 'types get_out_phrase
(*$*)
)
type ('a, 'b) type_comparison =
| Lt : ('a, 'b) type_comparison
| Eq : ('a, 'a) type_comparison
| Gt : ('a, 'b) type_comparison
let compare_ocaml_version
(*$ foreach_type (fun _ s -> printf "(type %s1) (type %s2)\n" s s) *)
(type out_value1) (type out_value2)
(type out_type1) (type out_type2)
(type out_class_type1) (type out_class_type2)
(type out_module_type1) (type out_module_type2)
(type out_sig_item1) (type out_sig_item2)
(type out_type_extension1) (type out_type_extension2)
(type out_phrase1) (type out_phrase2)
(*$*)
((module A) : <
(*$ foreach_type (fun _ s -> printf "%-21s : %s1;\n" s s) *)
out_value : out_value1;
out_type : out_type1;
out_class_type : out_class_type1;
out_module_type : out_module_type1;
out_sig_item : out_sig_item1;
out_type_extension : out_type_extension1;
out_phrase : out_phrase1;
(*$*)
> ocaml_version)
((module B) : <
(*$ foreach_type (fun _ s -> printf "%-21s : %s2;\n" s s) *)
out_value : out_value2;
out_type : out_type2;
out_class_type : out_class_type2;
out_module_type : out_module_type2;
out_sig_item : out_sig_item2;
out_type_extension : out_type_extension2;
out_phrase : out_phrase2;
(*$*)
> ocaml_version)
: (A.types, B.types) type_comparison
=
match A.Version with
| B.Version -> Eq
| _ when A.version < B.version -> Lt
| _ when A.version > B.version -> Gt
| _ -> assert false
type ('from, 'to_) migration_functions = {
(*$ foreach_type (fun _ s ->
printf "copy_%s: 'from get_%s -> 'to_ get_%s;\n" s s s) *)
copy_out_value: 'from get_out_value -> 'to_ get_out_value;
copy_out_type: 'from get_out_type -> 'to_ get_out_type;
copy_out_class_type: 'from get_out_class_type -> 'to_ get_out_class_type;
copy_out_module_type: 'from get_out_module_type -> 'to_ get_out_module_type;
copy_out_sig_item: 'from get_out_sig_item -> 'to_ get_out_sig_item;
copy_out_type_extension: 'from get_out_type_extension -> 'to_ get_out_type_extension;
copy_out_phrase: 'from get_out_phrase -> 'to_ get_out_phrase;
(*$*)
}
let id x = x
let migration_identity : ('a, 'a) migration_functions = {
(*$ foreach_type (fun _ s -> printf "copy_%s = id;\n" s) *)
copy_out_value = id;
copy_out_type = id;
copy_out_class_type = id;
copy_out_module_type = id;
copy_out_sig_item = id;
copy_out_type_extension = id;
copy_out_phrase = id;
(*$*)
}
let compose f g x = f (g x)
let migration_compose (ab : ('a, 'b) migration_functions) (bc : ('b, 'c) migration_functions) : ('a, 'c) migration_functions = {
(*$ foreach_type (fun _ s ->
printf "copy_%-21s = compose bc.copy_%-21s ab.copy_%s;\n" s s s) *)
copy_out_value = compose bc.copy_out_value ab.copy_out_value;
copy_out_type = compose bc.copy_out_type ab.copy_out_type;
copy_out_class_type = compose bc.copy_out_class_type ab.copy_out_class_type;
copy_out_module_type = compose bc.copy_out_module_type ab.copy_out_module_type;
copy_out_sig_item = compose bc.copy_out_sig_item ab.copy_out_sig_item;
copy_out_type_extension = compose bc.copy_out_type_extension ab.copy_out_type_extension;
copy_out_phrase = compose bc.copy_out_phrase ab.copy_out_phrase;
(*$*)
}
type _ migration += Migration : 'from ocaml_version * ('from, 'to_) migration_functions * 'to_ ocaml_version -> 'from migration
module type Migrate_module = sig
module From : Ast
module To : Ast
(*$ foreach_type (fun m s ->
printf "val copy_%-21s: From.%s.%s -> To.%s.%s\n" s m s m s) *)
val copy_out_value : From.Outcometree.out_value -> To.Outcometree.out_value
val copy_out_type : From.Outcometree.out_type -> To.Outcometree.out_type
val copy_out_class_type : From.Outcometree.out_class_type -> To.Outcometree.out_class_type
val copy_out_module_type : From.Outcometree.out_module_type -> To.Outcometree.out_module_type
val copy_out_sig_item : From.Outcometree.out_sig_item -> To.Outcometree.out_sig_item
val copy_out_type_extension : From.Outcometree.out_type_extension -> To.Outcometree.out_type_extension
val copy_out_phrase : From.Outcometree.out_phrase -> To.Outcometree.out_phrase
(*$*)
end
module Migration_functions
(A : OCaml_version) (B : OCaml_version)
(A_to_B : Migrate_module with module From = A.Ast and module To = B.Ast)
=
struct
let migration_functions : (A.types, B.types) migration_functions =
let open A_to_B in
{
(*$ foreach_type (fun _ s -> printf "copy_%s;\n" s) *)
copy_out_value;
copy_out_type;
copy_out_class_type;
copy_out_module_type;
copy_out_sig_item;
copy_out_type_extension;
copy_out_phrase;
(*$*)
}
end
module Register_migration (A : OCaml_version) (B : OCaml_version)
(A_to_B : Migrate_module with module From = A.Ast and module To = B.Ast)
(B_to_A : Migrate_module with module From = B.Ast and module To = A.Ast)
=
struct
let () = (
let is_undefined : type a. a migration -> bool = function
| Undefined -> true
| _ -> false
in
assert (A.version < B.version);
assert (is_undefined A.migration_info.next_version);
assert (is_undefined B.migration_info.previous_version);
let module A_to_B_fun = Migration_functions(A)(B)(A_to_B) in
let module B_to_A_fun = Migration_functions(B)(A)(B_to_A) in
A.migration_info.next_version <-
Migration ((module A), A_to_B_fun.migration_functions, (module B));
B.migration_info.previous_version <-
Migration ((module B), B_to_A_fun.migration_functions, (module A));
)
end
type 'from immediate_migration =
| No_migration : 'from immediate_migration
| Immediate_migration
: ('from, 'to_) migration_functions * 'to_ ocaml_version
-> 'from immediate_migration
let immediate_migration
(*$ foreach_type (fun _ s -> printf "(type %s)\n" s) *)
(type out_value)
(type out_type)
(type out_class_type)
(type out_module_type)
(type out_sig_item)
(type out_type_extension)
(type out_phrase)
(*$*)
((module A) : <
(*$ foreach_type (fun _ s -> printf "%-21s : %s;\n" s s) *)
out_value : out_value;
out_type : out_type;
out_class_type : out_class_type;
out_module_type : out_module_type;
out_sig_item : out_sig_item;
out_type_extension : out_type_extension;
out_phrase : out_phrase;
(*$*)
> ocaml_version)
direction
=
let version = match direction with
| `Next -> A.migration_info.next_version
| `Previous -> A.migration_info.previous_version
in
match version with
| Undefined -> No_migration
| Migration (_, funs, to_) -> Immediate_migration (funs, to_)
| _ -> assert false
let migrate
(*$ foreach_type (fun _ s -> printf "(type %s1) (type %s2)\n" s s) *)
(type out_value1) (type out_value2)
(type out_type1) (type out_type2)
(type out_class_type1) (type out_class_type2)
(type out_module_type1) (type out_module_type2)
(type out_sig_item1) (type out_sig_item2)
(type out_type_extension1) (type out_type_extension2)
(type out_phrase1) (type out_phrase2)
(*$*)
((module A) : <
(*$ foreach_type (fun _ s -> printf "%-21s : %s1;\n" s s) *)
out_value : out_value1;
out_type : out_type1;
out_class_type : out_class_type1;
out_module_type : out_module_type1;
out_sig_item : out_sig_item1;
out_type_extension : out_type_extension1;
out_phrase : out_phrase1;
(*$*)
> ocaml_version)
((module B) : <
(*$ foreach_type (fun _ s -> printf "%-21s : %s2;\n" s s) *)
out_value : out_value2;
out_type : out_type2;
out_class_type : out_class_type2;
out_module_type : out_module_type2;
out_sig_item : out_sig_item2;
out_type_extension : out_type_extension2;
out_phrase : out_phrase2;
(*$*)
> ocaml_version)
: (A.types, B.types) migration_functions
=
match A.Version with
| B.Version -> migration_identity
| _ ->
let direction = if A.version < B.version then `Next else `Previous in
let rec migrate (m : A.types immediate_migration) : (A.types, B.types) migration_functions =
match m with
| No_migration -> assert false
| Immediate_migration (f, (module To)) ->
match To.Version with
| B.Version -> f
| _ ->
match immediate_migration (module To) direction with
| No_migration -> assert false
| Immediate_migration (g, to2) ->
migrate (Immediate_migration (migration_compose f g, to2))
in
migrate (immediate_migration (module A) direction)
module Convert (A : OCaml_version) (B : OCaml_version) = struct
let {
(*$ foreach_type (fun _ s -> printf "copy_%s;\n" s) *)
copy_out_value;
copy_out_type;
copy_out_class_type;
copy_out_module_type;
copy_out_sig_item;
copy_out_type_extension;
copy_out_phrase;
(*$*)
} : (A.types, B.types) migration_functions =
migrate (module A) (module B)
end
(*$ foreach_version (fun suffix version ->
printf "module OCaml_%s = struct\n" suffix;
printf " module Ast = Ast_%s\n" suffix;
printf " include Make_witness(Ast_%s)\n" suffix;
printf " let version = %s\n" suffix;
printf " let string_version = %S\n" version;
printf "end\n";
printf "let ocaml_%s : OCaml_%s.types ocaml_version = (module OCaml_%s)\n"
suffix suffix suffix;
)
*)
module OCaml_408 = struct
module Ast = Ast_408
include Make_witness(Ast_408)
let version = 408
let string_version = "4.08"
end
let ocaml_408 : OCaml_408.types ocaml_version = (module OCaml_408)
module OCaml_409 = struct
module Ast = Ast_409
include Make_witness(Ast_409)
let version = 409
let string_version = "4.09"
end
let ocaml_409 : OCaml_409.types ocaml_version = (module OCaml_409)
module OCaml_410 = struct
module Ast = Ast_410
include Make_witness(Ast_410)
let version = 410
let string_version = "4.10"
end
let ocaml_410 : OCaml_410.types ocaml_version = (module OCaml_410)
module OCaml_411 = struct
module Ast = Ast_411
include Make_witness(Ast_411)
let version = 411
let string_version = "4.11"
end
let ocaml_411 : OCaml_411.types ocaml_version = (module OCaml_411)
module OCaml_412 = struct
module Ast = Ast_412
include Make_witness(Ast_412)
let version = 412
let string_version = "4.12"
end
let ocaml_412 : OCaml_412.types ocaml_version = (module OCaml_412)
module OCaml_413 = struct
module Ast = Ast_413
include Make_witness(Ast_413)
let version = 413
let string_version = "4.13"
end
let ocaml_413 : OCaml_413.types ocaml_version = (module OCaml_413)
module OCaml_414 = struct
module Ast = Ast_414
include Make_witness(Ast_414)
let version = 414
let string_version = "4.14"
end
let ocaml_414 : OCaml_414.types ocaml_version = (module OCaml_414)
module OCaml_500 = struct
module Ast = Ast_500
include Make_witness(Ast_500)
let version = 500
let string_version = "5.0"
end
let ocaml_500 : OCaml_500.types ocaml_version = (module OCaml_500)
module OCaml_51 = struct
module Ast = Ast_51
include Make_witness(Ast_51)
let version = 510
let string_version = "5.1"
end
let ocaml_51 : OCaml_51.types ocaml_version = (module OCaml_51)
module OCaml_52 = struct
module Ast = Ast_52
include Make_witness(Ast_52)
let version = 520
let string_version = "5.2"
end
let ocaml_52 : OCaml_52.types ocaml_version = (module OCaml_52)
module OCaml_53 = struct
module Ast = Ast_53
include Make_witness(Ast_53)
let version = 530
let string_version = "5.3"
end
let ocaml_53 : OCaml_53.types ocaml_version = (module OCaml_53)
module OCaml_54 = struct
module Ast = Ast_54
include Make_witness(Ast_54)
let version = 540
let string_version = "5.4"
end
let ocaml_54 : OCaml_54.types ocaml_version = (module OCaml_54)
module OCaml_55 = struct
module Ast = Ast_55
include Make_witness(Ast_55)
let version = 550
let string_version = "5.5"
end
let ocaml_55 : OCaml_55.types ocaml_version = (module OCaml_55)
(*$*)
let all_versions : (module OCaml_version) list = [
(*$foreach_version (fun suffix _ ->
printf "(module OCaml_%s : OCaml_version);\n" suffix)*)
(module OCaml_408 : OCaml_version);
(module OCaml_409 : OCaml_version);
(module OCaml_410 : OCaml_version);
(module OCaml_411 : OCaml_version);
(module OCaml_412 : OCaml_version);
(module OCaml_413 : OCaml_version);
(module OCaml_414 : OCaml_version);
(module OCaml_500 : OCaml_version);
(module OCaml_51 : OCaml_version);
(module OCaml_52 : OCaml_version);
(module OCaml_53 : OCaml_version);
(module OCaml_54 : OCaml_version);
(module OCaml_55 : OCaml_version);
(*$*)
]
(*$foreach_version_pair (fun a b ->
printf "include Register_migration(OCaml_%s)(OCaml_%s)\n" a b;
printf " (Migrate_parsetree_%s_%s)(Migrate_parsetree_%s_%s)\n" a b b a
)
*)
include Register_migration(OCaml_408)(OCaml_409)
(Migrate_parsetree_408_409)(Migrate_parsetree_409_408)
include Register_migration(OCaml_409)(OCaml_410)
(Migrate_parsetree_409_410)(Migrate_parsetree_410_409)
include Register_migration(OCaml_410)(OCaml_411)
(Migrate_parsetree_410_411)(Migrate_parsetree_411_410)
include Register_migration(OCaml_411)(OCaml_412)
(Migrate_parsetree_411_412)(Migrate_parsetree_412_411)
include Register_migration(OCaml_412)(OCaml_413)
(Migrate_parsetree_412_413)(Migrate_parsetree_413_412)
include Register_migration(OCaml_413)(OCaml_414)
(Migrate_parsetree_413_414)(Migrate_parsetree_414_413)
include Register_migration(OCaml_414)(OCaml_500)
(Migrate_parsetree_414_500)(Migrate_parsetree_500_414)
include Register_migration(OCaml_500)(OCaml_51)
(Migrate_parsetree_500_51)(Migrate_parsetree_51_500)
include Register_migration(OCaml_51)(OCaml_52)
(Migrate_parsetree_51_52)(Migrate_parsetree_52_51)
include Register_migration(OCaml_52)(OCaml_53)
(Migrate_parsetree_52_53)(Migrate_parsetree_53_52)
include Register_migration(OCaml_53)(OCaml_54)
(Migrate_parsetree_53_54)(Migrate_parsetree_54_53)
include Register_migration(OCaml_54)(OCaml_55)
(Migrate_parsetree_54_55)(Migrate_parsetree_55_54)
(*$*)
module OCaml_current = OCaml_OCAML_VERSION
let ocaml_current : OCaml_current.types ocaml_version = (module OCaml_current)
(* Make sure the preprocessing worked as expected *)
let _f (x : Outcometree.out_type) : OCaml_current.Ast.Outcometree.out_type = x
================================================
FILE: src/vendored-omp/src/migrate_parsetree_versions.mli
================================================
(**************************************************************************)
(* *)
(* OCaml Migrate Parsetree *)
(* *)
(* Frédéric Bour *)
(* Jérémie Dimino, Jane Street Europe *)
(* *)
(* Copyright 2017 Institut National de Recherche en Informatique et *)
(* en Automatique (INRIA). *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
(*$ #use "src/cinaps_helpers" $*)
(** {1 Abstracting an OCaml frontend} *)
(** Abstract view of a version of an OCaml Ast *)
module type Ast = sig
(*$ foreach_module (fun m types ->
printf "module %s : sig\n" m;
List.iter types ~f:(printf "type %s\n");
printf "end\n"
)
*)
module Outcometree : sig
type out_value
type out_type
type out_class_type
type out_module_type
type out_sig_item
type out_type_extension
type out_phrase
end
(*$*)
end
(* Shortcuts for talking about ast types outside of the module language *)
type 'a _types = 'a constraint 'a
= <
(*$ foreach_type (fun _ s -> printf "%-21s : _;\n" s) *)
out_value : _;
out_type : _;
out_class_type : _;
out_module_type : _;
out_sig_item : _;
out_type_extension : _;
out_phrase : _;
(*$*)
>
;;
(*$ foreach_type (fun _ s ->
printf "type 'a get_%s = 'x constraint 'a _types = < %s : 'x; .. >\n" s s
);
printf ";;\n" *)
type 'a get_out_value = 'x constraint 'a _types = < out_value : 'x; .. >
type 'a get_out_type = 'x constraint 'a _types = < out_type : 'x; .. >
type 'a get_out_class_type = 'x constraint 'a _types = < out_class_type : 'x; .. >
type 'a get_out_module_type = 'x constraint 'a _types = < out_module_type : 'x; .. >
type 'a get_out_sig_item = 'x constraint 'a _types = < out_sig_item : 'x; .. >
type 'a get_out_type_extension = 'x constraint 'a _types = < out_type_extension : 'x; .. >
type 'a get_out_phrase = 'x constraint 'a _types = < out_phrase : 'x; .. >
;;
(*$*)
(** A version of the OCaml frontend packs the ast with type witnesses
so that equalities can be recovered dynamically. *)
type _ witnesses (*IF_AT_LEAST 406 = private ..*)
(** [migration_info] is an opaque type that is used to generate migration
functions. *)
type _ migration_info
(** An OCaml frontend versions an Ast, version number and some witnesses for
conversion. *)
module type OCaml_version = sig
(** Ast definition for this version *)
module Ast : Ast
(* Version number as an integer, 402, 403, 404, ... *)
val version : int
(* Version number as a user-friendly string *)
val string_version : string (* 4.02, 4.03, 4.04, ... *)
(** Shortcut for talking about Ast types *)
type types = <
(*$ foreach_type (fun m s -> printf "%-21s : Ast.%s.%s;\n" s m s) *)
out_value : Ast.Outcometree.out_value;
out_type : Ast.Outcometree.out_type;
out_class_type : Ast.Outcometree.out_class_type;
out_module_type : Ast.Outcometree.out_module_type;
out_sig_item : Ast.Outcometree.out_sig_item;
out_type_extension : Ast.Outcometree.out_type_extension;
out_phrase : Ast.Outcometree.out_phrase;
(*$*)
> _types
(** A construtor for recovering type equalities between two arbitrary
versions. *)
type _ witnesses += Version : types witnesses
(** Information used to derive migration functions, see below *)
val migration_info : types migration_info
end
(** Representing an ocaml version in type language *)
type 'types ocaml_version =
(module OCaml_version
(*$ let sep = with_then_and () in
foreach_type (fun m s ->
printf "%t type Ast.%s.%s = 'types get_%s\n" sep m s s) *)
with type Ast.Outcometree.out_value = 'types get_out_value
and type Ast.Outcometree.out_type = 'types get_out_type
and type Ast.Outcometree.out_class_type = 'types get_out_class_type
and type Ast.Outcometree.out_module_type = 'types get_out_module_type
and type Ast.Outcometree.out_sig_item = 'types get_out_sig_item
and type Ast.Outcometree.out_type_extension = 'types get_out_type_extension
and type Ast.Outcometree.out_phrase = 'types get_out_phrase
(*$*)
)
(** {1 Concrete frontend instances} *)
(*$foreach_version (fun suffix _ ->
printf "module OCaml_%s : OCaml_version with module Ast = Ast_%s\n"
suffix suffix;
printf "val ocaml_%s : OCaml_%s.types ocaml_version\n" suffix suffix;
)*)
module OCaml_408 : OCaml_version with module Ast = Ast_408
val ocaml_408 : OCaml_408.types ocaml_version
module OCaml_409 : OCaml_version with module Ast = Ast_409
val ocaml_409 : OCaml_409.types ocaml_version
module OCaml_410 : OCaml_version with module Ast = Ast_410
val ocaml_410 : OCaml_410.types ocaml_version
module OCaml_411 : OCaml_version with module Ast = Ast_411
val ocaml_411 : OCaml_411.types ocaml_version
module OCaml_412 : OCaml_version with module Ast = Ast_412
val ocaml_412 : OCaml_412.types ocaml_version
module OCaml_413 : OCaml_version with module Ast = Ast_413
val ocaml_413 : OCaml_413.types ocaml_version
module OCaml_414 : OCaml_version with module Ast = Ast_414
val ocaml_414 : OCaml_414.types ocaml_version
module OCaml_500 : OCaml_version with module Ast = Ast_500
val ocaml_500 : OCaml_500.types ocaml_version
module OCaml_51 : OCaml_version with module Ast = Ast_51
val ocaml_51 : OCaml_51.types ocaml_version
module OCaml_52 : OCaml_version with module Ast = Ast_52
val ocaml_52 : OCaml_52.types ocaml_version
module OCaml_53 : OCaml_version with module Ast = Ast_53
val ocaml_53 : OCaml_53.types ocaml_version
module OCaml_54 : OCaml_version with module Ast = Ast_54
val ocaml_54 : OCaml_54.types ocaml_version
module OCaml_55 : OCaml_version with module Ast = Ast_55
val ocaml_55 : OCaml_55.types ocaml_version
(*$*)
(* An alias to the current compiler version *)
module OCaml_current = OCaml_OCAML_VERSION
val ocaml_current : OCaml_current.types ocaml_version
val all_versions : (module OCaml_version) list
(** {1 Migrating between different versions} *)
type ('a, 'b) type_comparison =
| Lt : ('a, 'b) type_comparison
| Eq : ('a, 'a) type_comparison
| Gt : ('a, 'b) type_comparison
val compare_ocaml_version : 'a ocaml_version -> 'b ocaml_version -> ('a, 'b) type_comparison
(** A record for migrating each AST construct between two known versions *)
type ('from, 'to_) migration_functions = {
(*$ foreach_type (fun _ s ->
printf "copy_%s: 'from get_%s -> 'to_ get_%s;\n" s s s) *)
copy_out_value: 'from get_out_value -> 'to_ get_out_value;
copy_out_type: 'from get_out_type -> 'to_ get_out_type;
copy_out_class_type: 'from get_out_class_type -> 'to_ get_out_class_type;
copy_out_module_type: 'from get_out_module_type -> 'to_ get_out_module_type;
copy_out_sig_item: 'from get_out_sig_item -> 'to_ get_out_sig_item;
copy_out_type_extension: 'from get_out_type_extension -> 'to_ get_out_type_extension;
copy_out_phrase: 'from get_out_phrase -> 'to_ get_out_phrase;
(*$*)
}
(** Migrating to the same version is no-op *)
val migration_identity : ('a, 'a) migration_functions
(** Migrations can be composed *)
val migration_compose : ('a, 'b) migration_functions -> ('b, 'c) migration_functions -> ('a, 'c) migration_functions
(** Represent the next or previous version of an Ast *)
type 'from immediate_migration =
| No_migration : 'from immediate_migration
(** Cannot migrate earliest or latest supported version *)
|
Immediate_migration :
('from, 'to_) migration_functions * 'to_ ocaml_version -> 'from immediate_migration
(** Pack the migration functions and the new version *)
val immediate_migration : 'types ocaml_version -> [< `Next | `Previous ] -> 'types immediate_migration
val migrate : 'from ocaml_version -> 'to_ ocaml_version -> ('from, 'to_) migration_functions
(** {1 Convenience definitions} *)
(** Module level migration *)
module Convert (A : OCaml_version) (B : OCaml_version) : sig
(*$ foreach_type (fun m s ->
let fq = sprintf "%s.%s" m s in
printf " val copy_%-21s : A.Ast.%-31s -> B.Ast.%s\n" s fq fq) *)
val copy_out_value : A.Ast.Outcometree.out_value -> B.Ast.Outcometree.out_value
val copy_out_type : A.Ast.Outcometree.out_type -> B.Ast.Outcometree.out_type
val copy_out_class_type : A.Ast.Outcometree.out_class_type -> B.Ast.Outcometree.out_class_type
val copy_out_module_type : A.Ast.Outcometree.out_module_type -> B.Ast.Outcometree.out_module_type
val copy_out_sig_item : A.Ast.Outcometree.out_sig_item -> B.Ast.Outcometree.out_sig_item
val copy_out_type_extension : A.Ast.Outcometree.out_type_extension -> B.Ast.Outcometree.out_type_extension
val copy_out_phrase : A.Ast.Outcometree.out_phrase -> B.Ast.Outcometree.out_phrase
(*$*)
end
================================================
FILE: src/vendored-omp/src/reason_omp.ml
================================================
(**************************************************************************)
(* *)
(* OCaml Migrate Parsetree *)
(* *)
(* Frédéric Bour *)
(* Jérémie Dimino, Jane Street Europe *)
(* *)
(* Copyright 2017 Institut National de Recherche en Informatique et *)
(* en Automatique (INRIA). *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
(*$ #use "src/cinaps_helpers" $*)
(* Shared definitions.
Mostly errors about features missing in older versions. *)
module Def = Migrate_parsetree_def
(* Copy of OCaml parsetrees *)
(*$foreach_version (fun suffix _ ->
printf "module Ast_%s = Ast_%s\n" suffix suffix
)*)
module Ast_408 = Ast_408
module Ast_409 = Ast_409
module Ast_410 = Ast_410
module Ast_411 = Ast_411
module Ast_412 = Ast_412
module Ast_413 = Ast_413
module Ast_414 = Ast_414
module Ast_500 = Ast_500
module Ast_51 = Ast_51
module Ast_52 = Ast_52
module Ast_53 = Ast_54
module Ast_54 = Ast_54
(*$*)
(* Manual migration between versions *)
(*$foreach_version_pair (fun x y ->
printf "module Migrate_%s_%s = Migrate_parsetree_%s_%s\n" x y x y;
printf "module Migrate_%s_%s = Migrate_parsetree_%s_%s\n" y x y x;
)*)
module Migrate_408_409 = Migrate_parsetree_408_409
module Migrate_409_408 = Migrate_parsetree_409_408
module Migrate_409_410 = Migrate_parsetree_409_410
module Migrate_410_409 = Migrate_parsetree_410_409
module Migrate_410_411 = Migrate_parsetree_410_411
module Migrate_411_410 = Migrate_parsetree_411_410
module Migrate_411_412 = Migrate_parsetree_411_412
module Migrate_412_411 = Migrate_parsetree_412_411
module Migrate_412_413 = Migrate_parsetree_412_413
module Migrate_413_412 = Migrate_parsetree_413_412
module Migrate_413_414 = Migrate_parsetree_413_414
module Migrate_414_413 = Migrate_parsetree_414_413
module Migrate_414_500 = Migrate_parsetree_414_500
module Migrate_500_414 = Migrate_parsetree_500_414
module Migrate_500_51 = Migrate_parsetree_500_51
module Migrate_51_500 = Migrate_parsetree_51_500
module Migrate_51_52 = Migrate_parsetree_51_52
module Migrate_52_51 = Migrate_parsetree_52_51
module Migrate_52_53 = Migrate_parsetree_52_53
module Migrate_53_52 = Migrate_parsetree_53_52
module Migrate_53_54 = Migrate_parsetree_53_54
module Migrate_54_53 = Migrate_parsetree_54_53
(*$*)
(* An abstraction of OCaml compiler versions *)
module Versions = Migrate_parsetree_versions
(* All versions are compatible with this signature *)
module type OCaml_version = Versions.OCaml_version
(*$foreach_version (fun suffix _ ->
printf "module OCaml_%s = Versions.OCaml_%s\n" suffix suffix
)*)
module OCaml_408 = Versions.OCaml_408
module OCaml_409 = Versions.OCaml_409
module OCaml_410 = Versions.OCaml_410
module OCaml_411 = Versions.OCaml_411
module OCaml_412 = Versions.OCaml_412
module OCaml_413 = Versions.OCaml_413
module OCaml_414 = Versions.OCaml_414
module OCaml_500 = Versions.OCaml_500
module OCaml_51 = Versions.OCaml_51
module OCaml_52 = Versions.OCaml_52
module OCaml_53 = Versions.OCaml_53
module OCaml_54 = Versions.OCaml_54
(*$*)
module OCaml_current = Versions.OCaml_current
(* A Functor taking two OCaml versions and producing a module of functions
migrating from one to the other. *)
module Convert = Versions.Convert
(* Aliases for compiler-libs modules that might be shadowed *)
module Compiler_libs = struct
module Location = Location
module Longident = Longident
module type Asttypes = module type of struct include Asttypes end
module rec Asttypes : Asttypes = Asttypes
module type Parsetree = module type of struct include Parsetree end
module rec Parsetree : Parsetree = Parsetree
module Docstrings = Docstrings
module Ast_helper = Ast_helper
module Ast_mapper = Ast_mapper
end
================================================
FILE: src/vendored-omp/src/stdlib0.ml
================================================
module Int = struct
let to_string = string_of_int
end
module Option = struct
let map f o =
match o with
| None -> None
| Some v -> Some (f v)
end
================================================
FILE: src/vendored-omp/tools/add_special_comments.ml
================================================
(* Add (*IF_CURRENT:= Parsetree.expression *) comments to type definitions. *)
open StdLabels
open Parsetree
[@@@warning "-40"]
let read_file fn =
let ic = open_in_bin fn in
let len = in_channel_length ic in
let s = really_input_string ic len in
close_in ic;
s
let collect_insertions structure =
let insertions = ref [] in
let add_after ~(loc:Location.t) txt =
insertions := (loc.loc_end.pos_cnum, txt) :: !insertions
in
List.iter structure ~f:(fun item ->
match item.pstr_desc with
| Pstr_module { pmb_name = module_name
; pmb_expr = { pmod_desc = Pmod_structure items; _ }
; _
} ->
List.iter items ~f:(fun item ->
match item.pstr_desc with
| Pstr_type (_, tds) ->
List.iter tds ~f:(fun td ->
match td.ptype_manifest with
| Some _ -> ()
| None ->
let name = td.ptype_name in
let params =
let to_string (ty, _) =
Format.asprintf "%a" Pprintast.core_type ty
in
match td.ptype_params with
| [] -> ""
| [param] -> to_string param ^ " "
| l ->
Printf.sprintf "(%s) "
(String.concat ~sep:", " (List.map l ~f:to_string))
in
Printf.ksprintf (add_after ~loc:name.loc)
" (*IF_CURRENT = %s%s.%s *)" params (match module_name.txt with None -> "X" | Some x -> x) name.txt)
| _ -> ())
| _ -> ());
List.sort !insertions ~cmp:(fun (a, _) (b, _) -> compare a b)
let () =
let fn = Sys.argv.(1) in
let file_contents = read_file fn in
let lb = Lexing.from_string file_contents in
Location.init lb fn;
let ast = Parse.implementation lb in
let insertions = collect_insertions ast in
let oc = open_out_bin fn in
let pos =
List.fold_left insertions ~init:0 ~f:(fun cur_pos (pos, txt) ->
output_substring oc file_contents cur_pos (pos - cur_pos);
output_string oc txt;
pos)
in
output_substring oc file_contents pos (String.length file_contents - pos);
close_out oc
================================================
FILE: src/vendored-omp/tools/add_special_comments.mli
================================================
(* empty *)
================================================
FILE: src/vendored-omp/tools/dune
================================================
(executable
(name add_special_comments)
(modules add_special_comments)
(libraries compiler-libs.common compiler-libs.bytecomp)
(enabled_if
(>= %{ocaml_version} 4.13)))
(executable
(name pp)
(modules pp pp_rewrite)
(libraries compiler-libs.common compiler-libs.bytecomp))
(ocamllex pp_rewrite)
(executable
(name gencopy)
(enabled_if
(>= %{ocaml_version} 5.4))
(modules gencopy)
(libraries compiler-libs.common compiler-libs.bytecomp))
================================================
FILE: src/vendored-omp/tools/gencopy.ml
================================================
(* This file is part of the ppx_tools package. It is released *)
(* under the terms of the MIT license (see LICENSE file). *)
(* Copyright 2013 Alain Frisch and LexiFi *)
(* This file has been modified/specialized for ocaml-migrate-parsetree *)
(* Generate code to perform a deep copy of a type into another
identical type (in another module). Used to generate a first
version of migration code between two versions of the same type,
to be then patched manually to perform actual migration. *)
let parse_longident =
Longident.parse [@@ocaml.warning "-3"]
let drop_prefix ~prefix s =
let plen = String.length prefix in
if plen > String.length s then None
else
try
for i = 0 to String.length prefix - 1 do
if not (Char.equal s.[i] prefix.[i]) then raise Exit
done;
Some (String.sub s plen (String.length s - plen))
with Exit -> None
let rec find_map f = function
| [] -> None
| x :: xs -> ( match f x with None -> find_map f xs | Some x -> Some x )
module Main : sig end = struct
open Types
open Asttypes
open Location
open Ast_helper
module Label = struct
type t = Asttypes.arg_label
type desc = Asttypes.arg_label =
| Nolabel
| Labelled of string
| Optional of string
let nolabel : t = Nolabel
end
let may_tuple ?loc tup = function
| [] -> None
| [ x ] -> Some x
| l -> Some (tup ?loc ?attrs:None (List.map (fun x -> None, x) l))
let lid ?(loc = !default_loc) s = mkloc (parse_longident s) loc
let constr ?loc ?attrs s args =
Exp.construct ?loc ?attrs (lid ?loc s) (may_tuple ?loc Exp.tuple args)
let unit ?loc ?attrs () = constr ?loc ?attrs "()" []
let tuple ?loc ?attrs = function
| [] -> unit ?loc ?attrs ()
| [ x ] -> x
| xs -> Exp.tuple ?loc ?attrs (List.map (fun x -> None, x) xs)
let app ?loc ?attrs f l =
if l = [] then f
else Exp.apply ?loc ?attrs f (List.map (fun a -> (Label.nolabel, a)) l)
let evar ?loc ?attrs s = Exp.ident ?loc ?attrs (lid ?loc s)
let let_in ?loc ?attrs ?(recursive = false) b body =
Exp.let_ ?loc ?attrs (if recursive then Recursive else Nonrecursive) b body
let func ?loc ?attrs l =
Exp.function_ ?loc ?attrs []
None
(Pfunction_cases ((List.map (fun (p, e) -> Exp.case p e) l), Location.none, []))
let lam ?loc ?attrs ?(label = Label.nolabel) ?default pat exp =
Exp.function_ ?loc ?attrs
[ { pparam_loc = Location.none; pparam_desc = (Pparam_val (label, default, pat)) } ]
None
(Pfunction_body exp)
let pvar ?(loc = !default_loc) ?attrs s = Pat.var ~loc ?attrs (mkloc s loc)
let may_ptuple ?loc tup = function
| [] -> None
| [ x ] -> Some x
| l -> Some (tup ?loc ?attrs:None (List.map (fun x -> None, x) l) Closed)
let pconstr ?loc ?attrs s args =
Pat.construct
?loc ?attrs
(lid ?loc s)
(Option.map (fun x -> ([], x)) (may_ptuple ?loc Pat.tuple args))
let selfcall m args = app (evar m) args
(*************************************************************************)
let env = Env.initial
let module_mapping = ref []
let rec clean = function
| [ "Location"; "t" ] -> [ "location" ]
| [] -> []
| [ x ] -> [ x ]
| [ _; "t" ] as x -> x
| _ :: xs -> clean xs
let print_fun s =
let lid = parse_longident s in
let s = Longident.flatten lid |> clean in
String.concat "_" ("copy" :: s)
let printed = Hashtbl.create 16
let meths = ref []
let rec gen ty =
if Hashtbl.mem printed ty then ()
else
let tylid = parse_longident ty in
let td =
try snd (Env.lookup_type tylid env ~loc:Location.none)
with Not_found ->
Format.eprintf "** Cannot resolve type %s@." ty;
exit 2
in
let prefix, local =
let open Longident in
match tylid with
| Ldot (m, s) -> (String.concat "." (Longident.flatten m.txt) ^ ".", s.txt)
| Lident s -> ("", s)
| Lapply _ -> assert false
in
let target_prefix =
match
find_map
(fun (v1, v2) ->
match drop_prefix ~prefix:v1 prefix with
| None -> None
| Some suffix -> Some (v2 ^ suffix) )
!module_mapping
with
| Some x -> x
| None -> prefix
in
let funname = print_fun ty in
Hashtbl.add printed ty ();
let params_in =
List.mapi
(fun i _ -> mkloc (Printf.sprintf "f%i" i) !default_loc)
td.type_params
in
let params_out =
List.mapi
(fun i _ -> mkloc (Printf.sprintf "g%i" i) !default_loc)
td.type_params
in
let env =
List.map2 (fun s t -> (Types.get_id t, evar s.txt)) params_in td.type_params
in
let make_result_t tyargs_in tyargs_out =
Typ.(
arrow Asttypes.Nolabel
(constr (lid (prefix ^ local)) tyargs_in)
(constr (lid (target_prefix ^ local)) tyargs_out))
in
let make_t tyargs_in tyargs_out =
List.fold_right2
(fun arg_in arg_out t ->
Typ.(
arrow Asttypes.Nolabel (arrow Asttypes.Nolabel arg_in arg_out) t)
)
tyargs_in tyargs_out
(make_result_t tyargs_in tyargs_out)
in
let tyargs_in = List.map (fun t -> Typ.var t.txt) params_in in
let tyargs_out = List.map (fun t -> Typ.var t.txt) params_out in
let t =
Typ.poly (params_in @ params_out) (make_t tyargs_in tyargs_out)
in
let concrete e =
let e =
List.fold_right
(fun x e -> lam x e)
(List.map (fun x -> pvar x.txt) params_in)
e
in
meths := Vb.mk (Pat.constraint_ (pvar funname) t) e :: !meths
in
let field ld =
let s = Ident.name ld.ld_id in
( (lid (prefix ^ s), pvar s),
(lid (target_prefix ^ s), tyexpr env ld.ld_type (evar s)) )
in
match (td.type_kind, td.type_manifest) with
| Type_record (l, _), _ ->
let l = List.map field l in
concrete
(lam
(Pat.record (List.map fst l) Closed)
(Exp.record (List.map snd l) None))
| Type_variant (l, _), _ ->
let case cd =
let c = Ident.name cd.cd_id in
match cd.cd_args with
| Cstr_tuple tys ->
let p, args = gentuple env tys in
(pconstr (prefix ^ c) p, constr (target_prefix ^ c) args)
| Cstr_record _l ->
failwith "Inline records are not yet supported."
in
concrete (func (List.map case l))
| Type_abstract _, Some t -> concrete (tyexpr_fun env t)
| Type_abstract _, None -> failwith ("Abstract type " ^ ty)
| Type_external _, _ ->
Format.eprintf "** External types are not yet supported %s@." ty;
()
| Type_open, _ ->
Format.eprintf "** Open types are not yet supported %s@." ty;
()
and gentuple env tl =
let arg i t =
let x = Printf.sprintf "x%i" i in
(pvar x, tyexpr env t (evar x))
in
List.split (List.mapi arg tl)
and genttuple env tl =
let arg i (lbl, t) =
let x = Printf.sprintf "x%i" i in
((lbl, pvar x), tyexpr env t (evar x))
in
List.split (List.mapi arg tl)
and tyexpr env ty x =
match Types.get_desc ty with
| Tvar _ -> (
match List.assoc (Types.get_id ty) env with
| f -> app f [ x ]
| exception Not_found -> failwith "Existentials not supported" )
| Ttuple tl ->
let p, e = genttuple env (tl : (_ * _ ) list) in
let_in [ Vb.mk (Pat.tuple p Closed) x ] (tuple e)
| Tconstr (path, [ t ], _) when Path.same path Predef.path_list ->
app (evar "List.map") [ tyexpr_fun env t; x ]
| Tconstr (path, [ t ], _) when Path.same path Predef.path_array ->
app (evar "Array.map") [ tyexpr_fun env t; x ]
| Tconstr (path, [ ], _) when Path.same path Predef.path_floatarray ->
app (evar "Float.Array.map") [ tyexpr_ffun "float"; x ]
| Tconstr (path, [ t ], _) when Path.same path Predef.path_option ->
app (evar "Option.map") [ tyexpr_fun env t; x ]
| Tconstr (path, [], _)
when Path.same path Predef.path_string
|| Path.same path Predef.path_bytes
|| Path.same path Predef.path_bool
|| Path.same path Predef.path_unit
|| Path.same path Predef.path_exn
|| Path.same path Predef.path_int
|| Path.same path Predef.path_char
|| Path.same path Predef.path_int32
|| Path.same path Predef.path_int64
|| Path.same path Predef.path_nativeint
|| Path.same path Predef.path_float
|| Path.same path Predef.path_extension_constructor ->
x
| Tconstr (path, tl, _) ->
let ty = Path.name path in
gen ty;
selfcall (print_fun ty) (List.map (tyexpr_fun env) tl @ [ x ])
| _ ->
Format.eprintf "** Cannot deal with type %a@." Printtyp.type_expr ty;
x
and tyexpr_ffun _ty = lam (pvar "x") (evar "x")
and tyexpr_fun env ty = lam (pvar "x") (tyexpr env ty (evar "x"))
let simplify =
(* (fun x -> <expr> x) ====> <expr> *)
let open Ast_mapper in
let super = default_mapper in
let value_binding this (vb : Parsetree.value_binding) =
let pvb_pat = this.pat this vb.pvb_pat in
let pvb_expr = super.expr this vb.pvb_expr in
let pvb_attributes = this.attributes this vb.pvb_attributes in
let pvb_loc = this.location this vb.pvb_loc in
let pvb_constraint = vb.pvb_constraint in
{ Parsetree.pvb_loc; pvb_attributes; pvb_expr; pvb_pat; pvb_constraint }
in
{ super with value_binding }
let add_mapping s =
let i =
try String.index s ':'
with Not_found -> failwith (Printf.sprintf "Cannot parse mapping %S" s)
in
module_mapping :=
( String.sub s 0 i ^ ".",
String.sub s (i + 1) (String.length s - i - 1) ^ "." )
:: !module_mapping
let args =
let open Arg in
[ ( "-I",
String
(fun s ->
Load_path.add_dir ~hidden:false (Misc.expand_directory Config.standard_library s)
),
"<dir> Add <dir> to the list of include directories" );
( "-map",
String add_mapping,
"Old_module:New_module Map types from Old_module to types in \
New_module" )
]
let usage = Printf.sprintf "%s [options] <type names>\n" Sys.argv.(0)
let main () =
Load_path.init ~auto_include:Compmisc.auto_include ~visible:[ Config.standard_library ] ~hidden:[];
Arg.parse (Arg.align args) gen usage;
let from_, to_ =
match !module_mapping with
| [ (from_, to_) ] ->
( String.sub from_ 0 (String.length from_ - 1),
String.sub to_ 0 (String.length to_ - 1) )
| _ -> failwith "expect one and only one '-map' argument"
in
let s =
[ Str.module_
(Mb.mk
(mkloc (Some "From") Location.none)
(Mod.ident (mkloc (parse_longident from_) Location.none)));
Str.module_
(Mb.mk (mkloc (Some "To") Location.none)
(Mod.ident (mkloc (parse_longident to_) Location.none)));
Str.value Recursive !meths
]
in
Format.printf "%a@." Pprintast.structure
(simplify.Ast_mapper.structure simplify s)
let () =
try main ()
with exn ->
Format.eprintf "%a@?" Errors.report_error exn;
exit 1
end
(* ../../_build/default/src/vendored-omp/tools/gencopy.exe -I . -I src/ -I +compiler-libs -map Ast_403:Ast_402 Ast_403.Outcometree.{out_phrase,out_type_extension} > src/migrate_parsetree_403_402_migrate.ml *)
(* ../../_build/default/src/vendored-omp/tools/gencopy.exe -I . -I src/ -I +compiler-libs -map Ast_402:Ast_403 Ast_402.Outcometree.{out_phrase,out_type_extension} > src/migrate_parsetree_402_403_migrate.ml *)
(* ../../_build/default/src/vendored-omp/tools/gencopy.exe -I . -I src/ -I +compiler-libs -map Ast_54:Ast_53 Ast_54.Outcometree.{out_phrase,out_type_extension} > src/migrate_parsetree_54_53_migrate.ml *)
(* ../../_build/default/src/vendored-omp/tools/gencopy.exe -I . -I src/ -I +compiler-libs -map Ast_414:Ast_500 Ast_414.Outcometree.{out_phrase,out_type_extension} > src/migrate_parsetree_414_500_migrate.ml *)
================================================
FILE: src/vendored-omp/tools/pp.ml
================================================
let () =
match Sys.argv with
| [|_; ocaml_version; fname|] ->
let is_current =
(Filename.basename fname = Printf.sprintf "ast_%s.ml" ocaml_version)
in
let ic = open_in_bin fname in
Printf.printf "# 1 %S\n" fname;
Pp_rewrite.rewrite is_current ocaml_version (Lexing.from_channel ic)
| _ ->
Printf.eprintf "%s: <ocaml-version> <file-name>\n"
Sys.executable_name;
exit 2
================================================
FILE: src/vendored-omp/tools/pp.mli
================================================
(* empty *)
================================================
FILE: src/vendored-omp/tools/pp_rewrite.mli
================================================
val rewrite : bool -> string -> Lexing.lexbuf -> unit
================================================
FILE: src/vendored-omp/tools/pp_rewrite.mll
================================================
{
open Printf
let print_ocaml_version version =
let patt_len = String.length "OCAML_VERSION" in
(* Note: the spaces in the replacements are to preserve locations *)
printf "%-*s" patt_len version
}
rule rewrite is_current ocaml_version = parse
| "OCAML_VERSION"
{ print_ocaml_version ocaml_version;
rewrite is_current ocaml_version lexbuf
}
| "(*IF_CURRENT " ([^'*']* as s) "*)"
{ let chunk = if is_current
then " " ^ s ^ " "
else Lexing.lexeme lexbuf
in
print_string chunk;
rewrite is_current ocaml_version lexbuf
}
| "(*IF_AT_LEAST " ([^'*' ' ']* as v) " " ([^'*']* as s) "*)"
{ let chunk = if (v <= ocaml_version)
then " " ^ String.make (String.length v + 1) ' ' ^ s ^ " "
else Lexing.lexeme lexbuf
in
print_string chunk;
rewrite is_current ocaml_version lexbuf
}
| "(*IF_NOT_AT_LEAST " ([^'*' ' ']* as v) " " ([^'*']* as s) "*)"
{ let chunk = if not (v <= ocaml_version)
then " " ^ String.make (String.length v + 1) ' ' ^ s ^ " "
else Lexing.lexeme lexbuf
in
print_string chunk;
rewrite is_current ocaml_version lexbuf
}
| _ as c
{ print_char c;
rewrite is_current ocaml_version lexbuf
}
| eof { () }
================================================
FILE: test/4.08/dune
================================================
(cram
(enabled_if
(or
(= %{ocaml_version} 4.08.0)
(= %{ocaml_version} 4.08.1)
(= %{ocaml_version} 4.08.2))))
================================================
FILE: test/4.08/error-comments.t
================================================
Format ./input.re
$ cat >input.re <<EOF
> /* this is an unterminated comment
> EOF
$ refmt ./input.re
File "./input.re", line 1, characters 0-2:
1 | /* this is an unterminated comment
^^
Error: Comment not terminated
[1]
================================================
FILE: test/4.08/error-lowercase_module.t
================================================
Print error for lowercase module
$ cat >input.re <<EOF
> module lowercase = {};
> EOF
$ refmt ./input.re
File "./input.re", line 1, characters 7-16:
1 | module lowercase = {};
^^^^^^^^^
Error: Module names must start with an uppercase letter.
[1]
================================================
FILE: test/4.08/error-lowercase_module_rec.t
================================================
Print error for lowercase module
$ cat >input.re <<EOF
> module rec lowercase = {};
> EOF
$ refmt ./input.re
File "./input.re", line 1, characters 11-20:
1 | module rec lowercase = {};
^^^^^^^^^
Error: Module names must start with an uppercase letter.
[1]
================================================
FILE: test/4.08/error-reservedField.t
================================================
Print error for type reserved keyword
$ cat >input.re <<EOF
> let x = {< type >};
> EOF
$ refmt ./input.re
File "./input.re", line 1, characters 11-15:
1 | let x = {< type >};
^^^^
Error: type is a reserved keyword, it cannot be used as an identifier. Try `type_` or `_type` instead
[1]
================================================
FILE: test/4.08/error-reservedRecord.t
================================================
Force error for type ./input.re
$ cat >input.re <<EOF
> let foo = { foo: "bar", type: "qux" };
> EOF
$ refmt ./input.re
File "./input.re", line 1, characters 24-28:
1 | let foo = { foo: "bar", type: "qux" };
^^^^
Error: type is a reserved keyword, it cannot be used as an identifier. Try `type_` or `_type` instead
[1]
================================================
FILE: test/4.08/error-reservedRecordPunned.t
================================================
Print error for type reserved keyword
$ cat >input.re <<EOF
> let foo = { ...other, type };
> EOF
$ refmt ./input.re
File "./input.re", line 1, characters 22-26:
1 | let foo = { ...other, type };
^^^^
Error: type is a reserved keyword, it cannot be used as an identifier. Try `type_` or `_type` instead
[1]
================================================
FILE: test/4.08/error-reservedRecordType.t
================================================
Print error for type reserved keyword
$ cat >input.re <<EOF
> type x = { type: string };
> EOF
$ refmt ./input.re
File "./input.re", line 1, characters 11-15:
1 | type x = { type: string };
^^^^
Error: type is a reserved keyword, it cannot be used as an identifier. Try `type_` or `_type` instead
[1]
================================================
FILE: test/4.08/error-reservedRecordTypePunned.t
================================================
Print error for type reserved keyword
$ cat >input.re <<EOF
> type x = { type };
> EOF
$ refmt ./input.re
File "./input.re", line 1, characters 11-15:
1 | type x = { type };
^^^^
Error: type is a reserved keyword, it cannot be used as an identifier. Try `type_` or `_type` instead
[1]
================================================
FILE: test/4.08/error-syntaxError.t
================================================
Force error for type ./input.re
$ cat >input.re <<EOF
> try (bad);
> EOF
$ refmt ./input.re
File "./input.re", line 1, characters 9-10:
1 | try (bad);
^
Error: Syntax error
[1]
================================================
FILE: test/4.08/mlSyntax.t/input.ml
================================================
(* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. *)
(**
* Testing pattern matching using ml syntax to exercise nesting of cases.
*)
type xyz =
| X
| Y of int * int * int
| Z of int * int
| Q
| R
let doubleBar = function
| X | Y (_, _, _) | Z (_, _) | Q -> true
| _ -> false
let doubleBarNested = function
| X | Y (_, _, _) | (Z (_, _) | Q) -> true
| _ -> false
(* Liberal use of the Any pattern being compatible with multiple arguments *)
let doubleBarAnyPatterns = function
| X | Y _ | Z _ | Q -> true
| _ -> false
let doubleBarNestedAnyPatterns = function
| X | Y _ | (Z _ | Q) -> true
| _ -> false
type bcd = B | C | D | E
type a = A of bcd
let result = match B with
| B
| C
| D
| E -> ()
let nested_match = function | A (B | C | D | E) -> 3
let some = Some (1, 2, 3)
let (===) = (=)
(* Test regression for https://github.com/facebook/Reason/issues/222 *)
let _ = Pervasives.(=)
let structuralEquality = 1 = 1
let physicalInequality = 1 <> 2
let referentialEquality = 2 == 2
let referentialInequality = 2 != 2
let equalityInIf = if 1 = 1 then true else false
let equalityWithIdentifiers = structuralEquality = referentialEquality
let nestedSome = Some (1, 2, Some (1, 2, 3))
let nestedSomeSimple = Some (Some (1, 2, 3))
module EM = struct
(** Exception *)
exception E of int * int
end
exception Ealias = EM.E
let switc = "match"
let switch = "match"
let switch_ = "match"
let pub = "method"
let pub_ = "method"
let pri = "private"
let pri_ = "private"
external private_ : unit -> unit = ""
external pri : unit -> unit = ""
type pub = int
type pub_ = int
================================================
FILE: test/4.08/mlSyntax.t/run.t
================================================
Format basic
$ refmt --print re ./input.ml > ./formatted.re
Type-check basics
$ ocamlc -c -pp 'refmt --print binary' -intf-suffix .rei -impl formatted.re
File "formatted.re", line 71, characters 8-23:
71 | let _ = Pervasives.(==);
^^^^^^^^^^^^^^^
Alert deprecated: module Stdlib.Pervasives
Use Stdlib instead.
If you need to stay compatible with OCaml < 4.07, you can use the
stdlib-shims library: https://github.com/ocaml/stdlib-shims
Format the formatted file back
$ refmt --print re ./formatted.re > ./formatted_back.re
Ensure idempotency: first format and second format are the same
$ diff formatted.re formatted_back.re
================================================
FILE: test/4.08/type-jsx.t/input.re
================================================
type component = {displayName: string};
module Bar = {
let createElement(~c=?,~children,()) {displayName: "test"};
};
module Nesting = {
let createElement(~children,()) {displayName: "test"};
};
module Much = {
let createElement(~children,()) {displayName: "test"};
};
module Foo = {
let createElement(~a=?,~b=?,~children,()) {displayName: "test"};
};
module One = {
let createElement(~test=?,~foo=?,~children,()) {displayName: "test"};
let createElementobvioustypo(~test,~children,()) {displayName: "test"};
};
module Two = {
let createElement(~foo=?,~children,()) {displayName: "test"};
};
module Sibling = {
let createElement(~foo=?,~children : list(component),()) = {displayName: "test"};
};
module Test = {
let createElement(~yo=?,~children,()) {displayName: "test"};
};
module So = {
let createElement(~children,()) {displayName: "test"};
};
module Foo2 = {
let createElement(~children,()) {displayName: "test"};
};
module Text = {
let createElement(~children,()) {displayName: "test"};
};
module Exp = {
let createElement(~children,()) {displayName: "test"};
};
module Pun = {
let createElement(~intended=?,~children,()) {displayName: "test"};
};
module Namespace = {
module Foo = {
let createElement(~intended=?,~anotherOptional as x=100,~children,()) {displayName: "test"};
};
};
module Optional1 = {
let createElement(~required,~children,()) {
switch (required) {
| Some(a) => {displayName: a}
| None => {displayName: "nope"}
};
};
};
module Optional2 = {
let createElement(~optional=?,~children,()) {
switch (optional) {
| Some(a) => {displayName: a}
| None => {displayName: "nope"}
};
};
};
module DefaultArg = {
let createElement(~default=Some("foo"),~children,()) {
switch (default) {
| Some(a) => {displayName: a}
| None => {displayName: "nope"}
};
};
};
module LotsOfArguments = {
let createElement(~argument1=?,~argument2=?,~argument3=?,~argument4=?,~argument5=?,~argument6=?,~children,()) {displayName: "test"};
};
let div(~argument1=?,~children,()) {
displayName: "test"
};
module List1 = {
let createElement(~children,()) {displayName: "test"};
};
module List2 = {
let createElement(~children,()) {displayName: "test"};
};
module List3 = {
let createElement(~children,()) {displayName: "test"};
};
module NotReallyJSX = {
let createElement(~foo,~bar,children) {displayName: "test"};
};
let notReallyJSX(~foo,~bar,children) {
displayName: "test"
};
let fakeRender (el:component) {
el.displayName
};
/* end of setup */
let (/><)(a,b) = a + b;
let (><)(a,b) = a + b;
let (/>) = fun(a,b) => a + b;
let ( ><\/ ) = fun(a,b) => a + b;
let tag1 = 5 />< 6;
let tag2 = 5 >< 7;
let tag3 = 5 /> 7;
let tag4 = 5 ><\/ 7;
let b = 2;
let selfClosing = <Foo />;
let selfClosing2 = <Foo a=1 b=true />;
let selfClosing3 =
<Foo
a="really long values that should"
b="cause the entire thing to wrap"
/>;
let a = <Foo> <Bar c=((a) => a + 2) /> </Foo>;
let a3 = <So> <Much> <Nesting> </Nesting> </Much> </So>;
let a4 = <Sibling> <One test=true foo=b /> <Two foo=b> </Two> </Sibling>;
let a5 = <Foo>"testing a string here"</Foo>;
let a6 =
<Foo2>
<Text>
"testing a string here"</Text>
<Test yo=1 /> <Text>"another string"</Text> <Bar> </Bar> <Exp>( 2 + 4 )</Exp>
</Foo2>;
let intended = true;
let punning = <Pun intended />;
let namespace = <Namespace.Foo />;
let c = <Foo> </Foo>;
let d = <Foo> </Foo>;
let spaceBefore = <So> <Much> <Nesting> </Nesting> </Much> </So>;
let spaceBefore2 = <So> <Much/> </So>;
let siblingNotSpaced = <So> <Much> </Much> <Much> </Much> </So>;
let jsxInList = [ <Foo> </Foo>];
let jsxInList2 = [ <Foo />];
let jsxInListA = [ <Foo> </Foo> ];
let jsxInListB = [ <Foo /> ];
let jsxInListC = [ <Foo> </Foo>];
let jsxInListD = [ <Foo />];
let jsxInList3 = [ <Foo> </Foo>, <Foo> </Foo>, <Foo> </Foo>];
let jsxInList4 = [ <Foo />, <Foo />, <Foo />];
let jsxInList5 = [ <Foo> </Foo>, <Foo> </Foo> ];
let jsxInList6 = [ <Foo />, <Foo /> ];
let jsxInList7 = [ <Foo> </Foo>, <Foo> </Foo>];
let jsxInList8 = [ <Foo />, <Foo />];
let testFunc(b) = b;
let jsxInFnCall = testFunc (<Foo />);
let lotsOfArguments = <LotsOfArguments argument1=1 argument2=2 argument3=3 argument4=4 argument5=5 argument6="test"> <Namespace.Foo /> </LotsOfArguments>;
let lowerCase = <div argument1=1 />;
let b = 0;
let d = 0;
/*
* Should pun the first example:
*/
let a = <Foo a=a>5</Foo>;
let a = <Foo a=b>5</Foo>;
let a = <Foo a=b b=d>5</Foo>;
let a = <Foo a>0.55</Foo>;
let a = [@JSX] Foo.createElement(~children=[],());
let ident = <Foo>{a}</Foo>;
let fragment1 = <> <Foo /> <Foo /> </>;
let fragment2 = <> <Foo /> <Foo /> </>;
let fragment3 = <> <Foo /> <Foo /> </>;
let fragment4 = <> <Foo /> <Foo /> </>;
let fragment5 = <> <Foo> </Foo> <Foo> </Foo> </>;
let fragment6 = <> <Foo> </Foo> <Foo> </Foo> </>;
let fragment7 = <> <Foo> </Foo> <Foo> </Foo> </>;
let fragment8 = <> <Foo> </Foo> <Foo> </Foo> </>;
let fragment9 = <> 2 2 2 2 </>;
let fragment10 = <>2.2 3.2 4.6 1.2 </>;
let fragment11 = <>"str"</>;
let fragment12 = <>(6 + 2) (6 + 2) (6 + 2)</>;
let fragment13 = <>fragment11 fragment11</>;
let listOfItems1 = <List1>1 2 3 4 5</List1>;
let listOfItems2 = <List2>1.0 2.8 3.8 4.0 5.1</List2>;
let listOfItems3 = <List3>fragment11 fragment11</List3>;
/*
* Several sequential simple jsx expressions must be separated with a space.
*/
let thisIsRight(a,b) = ();
let tagOne = fun(~children,()) => ();
let tagTwo = fun(~children,()) => ();
/* thisIsWrong <tagOne /><tagTwo />; */
thisIsRight(<tagOne />,<tagTwo />);
/* thisIsWrong <tagOne> </tagOne><tagTwo> </tagTwo>; */
thisIsRight(<tagOne> </tagOne>, <tagTwo> </tagTwo>);
let a = fun(~children,()) => ();
let b = fun(~children,()) => ();
let thisIsOkay =
<List1>
<a> </a> <b> </b>
<a/> <b/>
</List1>;
let thisIsAlsoOkay =
<List1>
<a> </a> <b> </b>
</List1>;
/* Doesn't make any sense, but suppose you defined an
infix operator to compare jsx */
<a /> < <b />;
<a /> > <b />;
<a> </a> < <b> </b>;
<a> </a> > <b> </b>;
let listOfListOfJsx = [<> </>];
let listOfListOfJsx = [<> <Foo> </Foo> </>];
let listOfListOfJsx = [<> <Foo /> </>, <> <Bar /> </> ];
let listOfListOfJsx = [<> <Foo /> </>, <> <Bar /> </>, ...listOfListOfJsx];
let sameButWithSpaces = [ <> </>];
let sameButWithSpaces = [ <> <Foo /> </>];
let sameButWithSpaces = [ <> <Foo /> </>, <> <Bar /> </>];
let sameButWithSpaces = [ <> <Foo /> </>, <> <Bar /> </>, ...sameButWithSpaces];
/*
* Test named tag right next to an open bracket.
*/
let listOfJsx = [];
let listOfJsx = [<Foo> </Foo>];
let listOfJsx = [<Foo />, <Bar /> ];
let listOfJsx = [<Foo />, <Bar /> , ...listOfJsx];
let sameButWithSpaces = [];
let sameButWithSpaces = [<Foo />];
let sameButWithSpaces = [<Foo />, <Bar />];
let sameButWithSpaces = [<Foo />, <Bar />, ...sameButWithSpaces];
/**
* Test no conflict with polymorphic variant types.
*/
type thisType = [`Foo | `Bar];
type t('a) = [< thisType ] as 'a;
let asd = [@JSX] [@foo] One.createElement(~test=true, ~foo=2, ~children=["a", "b"],());
let asd2 = [@JSX] [@foo] One.createElementobvioustypo(~test=false, ~children=["a", "b"],());
let span(~test : bool,~foo : int,~children,()) = 1;
let asd = [@JSX] [@foo] span(~test=true, ~foo=2, ~children=["a", "b"],());
/* "video" call doesn't end with a list, so the expression isn't converted to JSX */
let video(~test: bool,children) = children;
let asd2 = [@JSX] [@foo] video(~test=false,10);
let div(~children) = 1;
([@JSX] (((fun () => div) ())(~children=[])));
let myFun () {
<>
<Namespace.Foo intended=(true) anotherOptional=200 />
<Namespace.Foo intended=(true) anotherOptional=200 />
<Namespace.Foo intended=(true) anotherOptional=200>
<Foo />
<Foo />
<Foo />
<Foo />
<Foo />
<Foo />
<Foo />
</Namespace.Foo>
</>;
};
let myFun () {
<>
</>;
};
let myFun () {
<>
<Namespace.Foo intended=(true) anotherOptional=200 />
<Namespace.Foo intended=(true) anotherOptional=200 />
<Namespace.Foo intended=(true) anotherOptional=200>
<Foo />
<Foo />
<Foo />
<Foo />
<Foo />
<Foo />
<Foo />
</Namespace.Foo>
</>;
};
/**
* Children should wrap without forcing attributes to.
*/
<Foo a=10 b=0>
<Bar />
<Bar />
<Bar />
<Bar />
</Foo>;
/**
* Failing test cases:
*/
/* let res = <Foo a=10 b=(<Foo a=200 />) > */
/* <Bar /> */
/* </Foo>; */
/* let res = <Foo a=10 b=(<Foo a=200 />) />; */
let zzz = Some("oh hai");
/* this should be the only test that generates a warning. We're explicitly testing for this */
let optionalCallSite = <Optional1 required=?zzz />;
fakeRender(optionalCallSite);
let optionalArgument = <Optional2 />;
fakeRender(optionalArgument);
let optionalArgument = <Optional2 optional=?zzz />;
fakeRender(optionalArgument);
let defaultArg = <DefaultArg />;
fakeRender(defaultArg);
let defaultArg = <DefaultArg default=zzz />;
fakeRender(defaultArg);
([@JSX][@bla] NotReallyJSX.createElement([],~foo=1,~bar=2));
([@bla][@JSX] NotReallyJSX.createElement(~foo=1,[],~bar=2));
([@JSX][@bla] notReallyJSX([],~foo=1));
([@bla][@JSX] notReallyJSX(~foo=1,[],~bar=2));
/* children can be at any position */
([@JSX] span(~children=[],~test=true,~foo=2,()));
([@JSX] Optional1.createElement(~children=[],~required=Some("hi"),()));
/* preserve some other attributes too! */
([@JSX][@bla] span(~children=[],~test=true,~foo=2,()));
([@bla][@JSX] span(~children=[],~test=true,~foo=2,()));
([@JSX][@bla] Optional1.createElement(~children=[],~required=Some("hi"),()));
([@bla][@JSX] Optional1.createElement(~children=[],~required=Some("hi"),()));
/* Overeager JSX punning #1099 */
module Metal = {
let fiber = "fiber";
};
module OverEager = {
let createElement(~fiber,~children,()) {displayName: "test"};
};
let element = <OverEager fiber=Metal.fiber />;
type style = {
width: int,
height: int,
paddingTop: int,
paddingLeft: int,
paddingRight: int,
paddingBottom: int
};
module Window = {
let createElement(~style,~children,()) {displayName: "window"};
};
let w =
<Window
style={
width: 10,
height: 10,
paddingTop: 10,
paddingLeft: 10,
paddingRight: 10,
paddingBottom: 10
}
/>;
let foo = None;
let g = <Two ?foo />;
/* https://github.com/facebook/reason/issues/1428 */
<Foo> ...element </Foo>;
<Foo> ...((a) => 1) </Foo>;
<Foo> ...<Foo2 /> </Foo>;
<Foo> ...[|a|] </Foo>;
<Foo> ...(1, 2) </Foo>;
module Foo3 = {
let createElement = (~bar, ~children, ()) => ();
};
<Foo3 bar=<Foo /> />;
let onClickHandler = () => ();
let div = (~onClick, ~children, ()) => ();
<div onClick=onClickHandler> <> "foobar" </> </div>;
/*
* This is identical to just having "foobar" as a single JSX child (which means
* it's in a list).
*/
let yetAnotherDiv = <div onClick=onClickHandler>... <> "foobar" </> </div>;
let tl = [];
/*
* Spreading a list that has an identifier/expression as its tail. This should
* preserve the spread and preserve the braces. [list] is not considered
* simple for the purposes of spreading into JSX, or as a child.
*/
<div onClick=onClickHandler>...{[yetAnotherDiv, ...tl]}</div>;
/*
* This is equivalent to having no children.
*/
<div onClick=onClickHandler>...{[]}</div>;
================================================
FILE: test/4.08/type-jsx.t/run.t
================================================
Format basic
$ refmt --print re ./input.re > ./formatted.re
Print the formatted file
$ cat ./formatted.re
type component = {displayName: string};
module Bar = {
let createElement = (~c=?, ~children, ()) => {
displayName: "test",
};
};
module Nesting = {
let createElement = (~children, ()) => {
displayName: "test",
};
};
module Much = {
let createElement = (~children, ()) => {
displayName: "test",
};
};
module Foo = {
let createElement =
(~a=?, ~b=?, ~children, ()) => {
displayName: "test",
};
};
module One = {
let createElement =
(~test=?, ~foo=?, ~children, ()) => {
displayName: "test",
};
let createElementobvioustypo =
(~test, ~children, ()) => {
displayName: "test",
};
};
module Two = {
let createElement = (~foo=?, ~children, ()) => {
displayName: "test",
};
};
module Sibling = {
let createElement =
(~foo=?, ~children: list(component), ()) => {
displayName: "test",
};
};
module Test = {
let createElement = (~yo=?, ~children, ()) => {
displayName: "test",
};
};
module So = {
let createElement = (~children, ()) => {
displayName: "test",
};
};
module Foo2 = {
let createElement = (~children, ()) => {
displayName: "test",
};
};
module Text = {
let createElement = (~children, ()) => {
displayName: "test",
};
};
module Exp = {
let createElement = (~children, ()) => {
displayName: "test",
};
};
module Pun = {
let createElement =
(~intended=?, ~children, ()) => {
displayName: "test",
};
};
module Namespace = {
module Foo = {
let createElement =
(
~intended=?,
~anotherOptional as x=100,
~children,
(),
) => {
displayName: "test",
};
};
};
module Optional1 = {
let createElement = (~required, ~children, ()) => {
switch (required) {
| Some(a) => { displayName: a }
| None => { displayName: "nope" }
};
};
};
module Optional2 = {
let createElement =
(~optional=?, ~children, ()) => {
switch (optional) {
| Some(a) => { displayName: a }
| None => { displayName: "nope" }
};
};
};
module DefaultArg = {
let createElement =
(~default=Some("foo"), ~children, ()) => {
switch (default) {
| Some(a) => { displayName: a }
| None => { displayName: "nope" }
};
};
};
module LotsOfArguments = {
let createElement =
(
~argument1=?,
~argument2=?,
~argument3=?,
~argument4=?,
~argument5=?,
~argument6=?,
~children,
(),
) => {
displayName: "test",
};
};
let div = (~argument1=?, ~children, ()) => {
displayName: "test",
};
module List1 = {
let createElement = (~children, ()) => {
displayName: "test",
};
};
module List2 = {
let createElement = (~children, ()) => {
displayName: "test",
};
};
module List3 = {
let createElement = (~children, ()) => {
displayName: "test",
};
};
module NotReallyJSX = {
let createElement = (~foo, ~bar, children) => {
displayName: "test",
};
};
let notReallyJSX = (~foo, ~bar, children) => {
displayName: "test",
};
let fakeRender = (el: component) => {
el.displayName;
};
/* end of setup */
let (/><) = (a, b) => a + b;
let (><) = (a, b) => a + b;
let (/>) = (a, b) => a + b;
let (></) = (a, b) => a + b;
let tag1 = 5 />< 6;
let tag2 = 5 >< 7;
let tag3 = 5 /> 7;
let tag4 = 5 ></ 7;
let b = 2;
let selfClosing = <Foo />;
let selfClosing2 = <Foo a=1 b=true />;
let selfClosing3 =
<Foo
a="really long values that should"
b="cause the entire thing to wrap"
/>;
let a = <Foo> <Bar c={a => a + 2} /> </Foo>;
let a3 = <So> <Much> <Nesting /> </Much> </So>;
let a4 =
<Sibling>
<One test=true foo=b />
<Two foo=b />
</Sibling>;
let a5 = <Foo> "testing a string here" </Foo>;
let a6 =
<Foo2>
<Text> "testing a string here" </Text>
<Test yo=1 />
<Text> "another string" </Text>
<Bar />
<Exp> {2 + 4} </Exp>
</Foo2>;
let intended = true;
let punning = <Pun intended />;
let namespace = <Namespace.Foo />;
let c = <Foo />;
let d = <Foo />;
let spaceBefore =
<So> <Much> <Nesting /> </Much> </So>;
let spaceBefore2 = <So> <Much /> </So>;
let siblingNotSpaced =
<So> <Much /> <Much /> </So>;
let jsxInList = [<Foo />];
let jsxInList2 = [<Foo />];
let jsxInListA = [<Foo />];
let jsxInListB = [<Foo />];
let jsxInListC = [<Foo />];
let jsxInListD = [<Foo />];
let jsxInList3 = [<Foo />, <Foo />, <Foo />];
let jsxInList4 = [<Foo />, <Foo />, <Foo />];
let jsxInList5 = [<Foo />, <Foo />];
let jsxInList6 = [<Foo />, <Foo />];
let jsxInList7 = [<Foo />, <Foo />];
let jsxInList8 = [<Foo />, <Foo />];
let testFunc = b => b;
let jsxInFnCall = testFunc(<Foo />);
let lotsOfArguments =
<LotsOfArguments
argument1=1
argument2=2
argument3=3
argument4=4
argument5=5
argument6="test">
<Namespace.Foo />
</LotsOfArguments>;
let lowerCase = <div argument1=1 />;
let b = 0;
let d = 0;
/*
* Should pun the first example:
*/
let a = <Foo a> 5 </Foo>;
let a = <Foo a=b> 5 </Foo>;
let a = <Foo a=b b=d> 5 </Foo>;
let a = <Foo a> 0.55 </Foo>;
let a = <Foo />;
let ident = <Foo> a </Foo>;
let fragment1 = <> <Foo /> <Foo /> </>;
let fragment2 = <> <Foo /> <Foo /> </>;
let fragment3 = <> <Foo /> <Foo /> </>;
let fragment4 = <> <Foo /> <Foo /> </>;
let fragment5 = <> <Foo /> <Foo /> </>;
let fragment6 = <> <Foo /> <Foo /> </>;
let fragment7 = <> <Foo /> <Foo /> </>;
let fragment8 = <> <Foo /> <Foo /> </>;
let fragment9 = <> 2 2 2 2 </>;
let fragment10 = <> 2.2 3.2 4.6 1.2 </>;
let fragment11 = <> "str" </>;
let fragment12 = <> {6 + 2} {6 + 2} {6 + 2} </>;
let fragment13 = <> fragment11 fragment11 </>;
let listOfItems1 = <List1> 1 2 3 4 5 </List1>;
let listOfItems2 =
<List2> 1.0 2.8 3.8 4.0 5.1 </List2>;
let listOfItems3 =
<List3> fragment11 fragment11 </List3>;
/*
* Several sequential simple jsx expressions must be separated with a space.
*/
let thisIsRight = (a, b) => ();
let tagOne = (~children, ()) => ();
let tagTwo = (~children, ()) => ();
/* thisIsWrong <tagOne /><tagTwo />; */
thisIsRight(<tagOne />, <tagTwo />);
/* thisIsWrong <tagOne> </tagOne><tagTwo> </tagTwo>; */
thisIsRight(<tagOne />, <tagTwo />);
let a = (~children, ()) => ();
let b = (~children, ()) => ();
let thisIsOkay =
<List1> <a /> <b /> <a /> <b /> </List1>;
let thisIsAlsoOkay =
<List1> <a /> <b /> </List1>;
/* Doesn't make any sense, but suppose you defined an
infix operator to compare jsx */
<a /> < <b />;
<a /> > <b />;
<a /> < <b />;
<a /> > <b />;
let listOfListOfJsx = [<> </>];
let listOfListOfJsx = [<> <Foo /> </>];
let listOfListOfJsx = [
<> <Foo /> </>,
<> <Bar /> </>,
];
let listOfListOfJsx = [
<> <Foo /> </>,
<> <Bar /> </>,
...listOfListOfJsx,
];
let sameButWithSpaces = [<> </>];
let sameButWithSpaces = [<> <Foo /> </>];
let sameButWithSpaces = [
<> <Foo /> </>,
<> <Bar /> </>,
];
let sameButWithSpaces = [
<> <Foo /> </>,
<> <Bar /> </>,
...sameButWithSpaces,
];
/*
* Test named tag right next to an open bracket.
*/
let listOfJsx = [];
let listOfJsx = [<Foo />];
let listOfJsx = [<Foo />, <Bar />];
let listOfJsx = [
<Foo />,
<Bar />,
...listOfJsx,
];
let sameButWithSpaces = [];
let sameButWithSpaces = [<Foo />];
let sameButWithSpaces = [<Foo />, <Bar />];
let sameButWithSpaces = [
<Foo />,
<Bar />,
...sameButWithSpaces,
];
/**
* Test no conflict with polymorphic variant types.
*/
type thisType = [
| `Foo
| `Bar
];
type t('a) = [< thisType] as 'a;
let asd =
[@foo] <One test=true foo=2> "a" "b" </One>;
let asd2 =
[@foo]
<One.createElementobvioustypo test=false>
"a"
"b"
</One.createElementobvioustypo>;
let span =
(~test: bool, ~foo: int, ~children, ()) => 1;
let asd =
[@foo] <span test=true foo=2> "a" "b" </span>;
/* "video" call doesn't end with a list, so the expression isn't converted to JSX */
let video = (~test: bool, children) => children;
let asd2 = [@foo] [@JSX] video(~test=false, 10);
let div = (~children) => 1;
[@JSX] ((() => div)())(~children=[]);
let myFun = () => {
<>
<Namespace.Foo
intended=true
anotherOptional=200
/>
<Namespace.Foo
intended=true
anotherOptional=200
/>
<Namespace.Foo
intended=true anotherOptional=200>
<Foo />
<Foo />
<Foo />
<Foo />
<Foo />
<Foo />
<Foo />
</Namespace.Foo>
</>;
};
let myFun = () => {
<> </>;
};
let myFun = () => {
<>
<Namespace.Foo
intended=true
anotherOptional=200
/>
<Namespace.Foo
intended=true
anotherOptional=200
/>
<Namespace.Foo
intended=true anotherOptional=200>
<Foo />
<Foo />
<Foo />
<Foo />
<Foo />
<Foo />
<Foo />
</Namespace.Foo>
</>;
};
/**
* Children should wrap without forcing attributes to.
*/
<Foo a=10 b=0>
<Bar />
<Bar />
<Bar />
<Bar />
</Foo>;
/**
* Failing test cases:
*/
/* let res = <Foo a=10 b=(<Foo a=200 />) > */
/* <Bar /> */
/* </Foo>; */
/* let res = <Foo a=10 b=(<Foo a=200 />) />; */
let zzz = Some("oh hai");
/* this should be the only test that generates a warning. We're explicitly testing for this */
let optionalCallSite =
<Optional1 required=?zzz />;
fakeRender(optionalCallSite);
let optionalArgument = <Optional2 />;
fakeRender(optionalArgument);
let optionalArgument =
<Optional2 optional=?zzz />;
fakeRender(optionalArgument);
let defaultArg = <DefaultArg />;
fakeRender(defaultArg);
let defaultArg = <DefaultArg default=zzz />;
fakeRender(defaultArg);
([@bla]
[@JSX]
NotReallyJSX.createElement([], ~foo=1, ~bar=2));
([@bla]
[@JSX]
NotReallyJSX.createElement(~foo=1, [], ~bar=2));
([@bla] [@JSX] notReallyJSX([], ~foo=1));
([@bla] [@JSX] notReallyJSX(~foo=1, [], ~bar=2));
/* children can be at any position */
<span test=true foo=2 />;
<Optional1 required={Some("hi")} />;
/* preserve some other attributes too! */
([@bla] <span test=true foo=2 />);
([@bla] <span test=true foo=2 />);
([@bla] <Optional1 required={Some("hi")} />);
([@bla] <Optional1 required={Some("hi")} />);
/* Overeager JSX punning #1099 */
module Metal = {
let fiber = "fiber";
};
module OverEager = {
let createElement = (~fiber, ~children, ()) => {
displayName: "test",
};
};
let element = <OverEager fiber=Metal.fiber />;
type style = {
width: int,
height: int,
paddingTop: int,
paddingLeft: int,
paddingRight: int,
paddingBottom: int,
};
module Window = {
let createElement = (~style, ~children, ()) => {
displayName: "window",
};
};
let w =
<Window
style={
width: 10,
height: 10,
paddingTop: 10,
paddingLeft: 10,
paddingRight: 10,
paddingBottom: 10,
}
/>;
let foo = None;
let g = <Two ?foo />;
/* https://github.com/facebook/reason/issues/1428 */
<Foo> ...element </Foo>;
<Foo> ...{a => 1} </Foo>;
<Foo> ...<Foo2 /> </Foo>;
<Foo> ...[|a|] </Foo>;
<Foo> ...(1, 2) </Foo>;
module Foo3 = {
let createElement = (~bar, ~children, ()) =>
();
};
<Foo3 bar={<Foo />} />;
let onClickHandler = () => ();
let div = (~onClick, ~children, ()) => ();
<div onClick=onClickHandler>
<> "foobar" </>
</div>;
/*
* This is identical to just having "foobar" as a single JSX child (which means
* it's in a list).
*/
let yetAnotherDiv =
<div onClick=onClickHandler> "foobar" </div>;
let tl = [];
/*
* Spreading a list that has an identifier/expression as its tail. This should
* preserve the spread and preserve the braces. [list] is not considered
* simple for the purposes of spreading into JSX, or as a child.
*/
<div onClick=onClickHandler>
...{[yetAnotherDiv, ...tl]}
</div>;
/*
* This is equivalent to having no children.
*/
<div onClick=onClickHandler />;
Type-check basics
$ ocamlc -c -pp 'refmt --print binary' -intf-suffix .rei -impl formatted.re
File "formatted.re", line 463, characters 23-26:
463 | <Optional1 required=?zzz />;
^^^
Warning 43: the label required is not optional.
Format the formatted file back
$ refmt --print re ./formatted.re > ./formatted_back.re
Ensure idempotency: first format and second format are the same
$ diff formatted.re formatted_back.re
================================================
FILE: test/4.08/typecheck-features.t
================================================
$ cat > input.mli <<EOF
> module X : sig
> type t
> end
>
> module M := X
>
> module N := X [@@attr]
>
> type y = int
>
> type z = int
>
> type t = int
>
> type x := y
>
> type y := z [@@attr1]
> and w := t [@@attr2]
>
> type x' = | and y' = |
> EOF
Format basic
$ refmt --print re ./input.mli > ./formatted.rei
Type-check basics
$ ocamlc -c -pp 'refmt --print binary' -intf-suffix .rei -intf formatted.rei
Format the formatted file back
$ refmt --print re ./formatted.rei > ./formatted_back.rei
Ensure idempotency: first format and second format are the same
$ diff formatted.rei formatted_back.rei
================================================
FILE: test/4.10/attributes-re.t/input.re
================================================
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
/**
* Generally, dangling attributes [@..] apply to everything to the left of it,
* up until a comma, equals asignment, arrow, bar, or infix symbol (+/-) or
* prefix.
*
* This has a nice side effect when printing the terms:
* If a node has attributes attached to it,
*/
[@ocaml.text "Floating comment text should be removed"];
/**
* Core language features:
* ----------------------
*/
[@ocaml.doc "Floating doc text should be removed"];
[@itemAttributeOnTypeDef] [@ocaml.text "removed text on type def"]
type itemText = int;
type nodeText = [@ocaml.text "removed text on item"] int;
[@itemAttributeOnTypeDef]
[@ocaml.text "removed text on type def"]
type nodeAndItemText =
[@ocaml.text "removed text on item"] int;
[@itemAttributeOnTypeDef] [@ocaml.doc "removed doc on type def"]
type itemDoc = int;
[@itemAttributeOnTypeDef]
type nodeDoc = [@ocaml.text "removed text on item"] int;
[@itemAttributeOnTypeDef] [@ocaml.doc "removed doc on type def"]
type nodeAndItemDoc =
[@ocaml.text "removed text on item"] int;
[@itemAttributeOnTypeDef]
type x = int;
type attributedInt = [@onTopLevelTypeDef] int;
[@itemAttributeOnTypeDef]
type attributedIntsInTuple = ([@onInt] int, [@onFloat] float);
type myDataType('x,'y) = | MyDataType('x,'y);
type myType =
[@onEntireType]
myDataType ([@onOptionInt] option(int),
[@onOption] option(float));
let thisInst : myType =
[@attOnEntireDatatype] MyDataType(Some(10),Some(10.0));
let thisInst : myType =
[@attOnEntireDatatype] MyDataType([@onFirstParam] Some(10), Some(10.0));
let x = ([@onHello] "hello");
let x = [@onHello] "hello";
let x = "hello" ++ ([@onGoodbye] "goodbye");
let x = ([@onHello] "hello") ++ "goodbye";
let x = [@onHello] "hello" ++ "goodbye";
let x = "hello" ++ [@onGoodbye] "goodbye";
let x = [@onEverything] ("hello" ++ "goodbye");
let x = 10 + ([@on20] 20);
let x = 10 + [@on20] 20;
let x = [@on10] 10 + 20;
let x = ([@on10] 10) + 20;
let x = [@attrEverything] (10 + 20);
let x = 10 - ([@on20] 20);
let x = 10 - [@on20] 20;
let x = [@on10] 10 - 20;
let x = ([@on10] 10) - 20;
let x = [@attrEntireEverything] (10 - 20);
let x = true && ([@onFalse] false);
let x = true && [@onFalse] false;
let x = [@onTrue] true && false;
let x = ([@onTrue] true) && false;
let x = [@attrEverything] (true && false);
/* now make sure to try with variants (tagged and `) */
/**
* How attribute parsings respond to other syntactic constructs.
*/
let add(a) { [@onRet] a };
let add = fun(a) => [@onRet] a;
let add = [@onEntireFunction] (fun(a) => a);
let res = if (true) false else [@onFalse] false;
let res = [@onEntireIf] (if (true) false else false);
let add(a,b) = [@onEverything] ([@onA] a + b);
let add(a,b) = [@onEverything] ([@onA]a + ([@onB]b));
let add = (a,b) => a + [@onB]b;
let both = [@onEntireFunction](fun(a) => a);
let both(a,b) = [@onEverything]([@onA]a && b);
let both(a,b) = [@onA] a && [@onB] ([@onB] b);
let both = fun(a,b) => [@onEverything](a && b);
let thisVal = 10;
let x = 20 + - [@onFunctionCall] add(thisVal,thisVal);
let x = [@onEverything] (20 + - add(thisVal,thisVal));
let x = - [@onFunctionCall] add(thisVal,thisVal);
let x = [@onEverything] (- add(thisVal,thisVal));
let bothTrue(x,y) = {contents: x && y};
let something = [@onEverythingToRightOfEquals](bothTrue(true,true)^);
let something = ([@onlyOnArgumentToBang]bothTrue(true,true))^;
let res = [@appliesToEntireFunctionApplication] add(2,4);
[@appliesToEntireFunctionApplication]add(2,4);
let myObj = {
pub p () = {
pub z () = 10
};
};
let result = [@onSecondSend]([@attOnFirstSend]myObj#p ())#z ();
[@onRecordFunctions]
type recordFunctions = {
p: (unit) => ([@onUnit] recordFunctions),
q: [@onArrow] ((unit) => unit)
}
[@onUnusedType]
and unusedType = unit;
[@onMyRecord]
let rec myRecord = {
p: fun () => myRecord,
q: fun () => ()
}
[@onUnused]
and unused = ();
let result = [@onSecondSend]([@attOnFirstSend]myRecord.p()).q();
[@onVariantType]
type variantType =
[@onInt] | Foo(int)
| Bar ([@onInt] int)
| Baz;
[@onVariantType]
type gadtType('x) =
| Foo(int) : [@onFirstRow] gadtType(int)
| Bar ([@onInt]int) : [@onSecondRow]gadtType(unit)
| Baz: [@onThirdRow] gadtType ([@onUnit] unit);
[@floatingTopLevelStructureItem hello];
[@itemAttributeOnEval]
print_string("hello");
[@itemAttrOnFirst]
let firstBinding = "first"
[@itemAttrOnSecond]
and secondBinding = "second";
/**
* Let bindings.
* ----------------------
*/
let showLets () = [@onOuterLet] {
let tmp = 20;
[@onFinalLet] {
let tmpTmp = tmp + tmp;
tmpTmp + tmpTmp;
}
};
/**
* Classes:
* ------------
*/
/**
* In curried sugar, the class_expr attribute will apply to the return.
*/
[@moduleItemAttribute]
class boxA('a) (init: 'a) = [@onReturnClassExpr] {
[@ocaml.text "Floating comment text should be removed"];
[@ocaml.doc "Floating comment text should be removed"];
pub pr = init + init + init;
};
/**
* In non-curried sugar, the class_expr still sticks to "the simple thing".
*/
class boxB('a) =
fun (init: 'a) => [@stillOnTheReturnBecauseItsSimple] {
pub pr = init + init + init;
};
/* To be able to put an attribute on just the return in that case, use
* parens. */
[@onBoxC x ; y]
class boxC('a) = [@onEntireFunction] (
fun (init: 'a) => (
[@onReturnClassExpr] {
pub pr = init + init + init;
}
)
);
[@moduleItemAttribute onTheTupleClassItem;]
class tupleClass('a,'b)(init: ('a, 'b)) {
let one = [@exprAttr ten;] 10;
let two = [@exprAttr twenty;] 20
and three = [@exprAttr thirty;] 30;
[@pr prMember;]
pub pr = one + two + three;
};
[@structureItem]
class type addablePointClassType = {
[@ocaml.text "Floating comment text should be removed"];
[@ocaml.doc "Floating comment text should be removed"];
pub x: int;
pub y: int;
pub add: (addablePointClassType, addablePointClassType) => int;
}
[@structureItem]
and anotherClassType = {
pub foo: int;
pub bar: int;
};
class type _x = [@bs]{ pub height : int };
class type _y { [@bs.set] pub height : int };
[@attr] class type _z { pub height : int };
module NestedModule {
[@floatingNestedStructureItem hello];
};
[@structureItem]
module type HasAttrs = {
[@onTypeDef]
type t = int;
[@floatingNestedSigItem hello];
[@sigItem]
class type foo = {pub foo: int; pub bar: int;};
[@sigItem]
class fooBar: (int) => foo;
[@ocaml.text "Floating comment text should be removed"];
[@ocaml.doc "Floating comment text should be removed"];
};
type s = S(string);
let S ([@onStr] str) = S ([@onHello]"hello");
let [@onConstruction](S(str)) = [@onConstruction](S("hello"));
type xy = | X(string)
| Y(string);
let myFun = fun ([@onConstruction]X(hello) | [@onConstruction]Y(hello)) => hello;
let myFun = fun (X ([@onHello] hello ) | Y ([@onHello]hello )) => hello;
/* Another bug: Cannot have an attribute on or pattern
let myFun = fun ((X(hello) | Y(hello)) [@onOrPattern]) => hello;
*/
/* Melange FFI item attributes */
[@bs.val]
external imul : (int, int) => int = "Math.imul";
let module Js {
type t('a);
};
type classAttributesOnKeys = {
.
[@bs.set] key1 : string,
/* The follow two are the same */
[@bs.get {null}] key2 : [@onType2] Js.t(int),
[@bs.get {null}] key3 : ([@onType2] (Js.t(int))),
key4 : Js.t ([@justOnInt] int)
};
/* extensible variants */
type attr = ..;
[@block]
type attr +=
[@tag1] [@tag2] | Str
[@tag3] | Float ;
type reconciler('props) = ..;
[@onVariantType]
type reconciler('props) +=
| Foo(int) : [@onFirstRow] reconciler(int)
| Bar ([@onInt] int) : [@onSecondRow] reconciler(unit)
[@baz] | Baz: [@onThirdRow] reconciler ([@onUnit] unit);
type water = ..;
type water += pri [@foo] | [@foo2] MineralWater | SpringWater;
type cloud = string;
type water += pri | [@h2o] PreparedWater | [@nature] RainWater(cloud) | [@toxic] MeltedSnowWaterFromNuclearWastelandWithALineBreakBecauseTheNameIsSoLong;
/* reasonreact */
type element;
type reactElement;
type reactClass;
/* "react-dom" shouldn't spread the attribute over multiple lines */
[@bs.val] [@bs.module "react-dom"]
external render : (reactElement, element) => unit = "render";
[@bs.module "f"]
external f : (int) => int = "f";
[@bs.val] [@bs.module "react"] [@bs.splice]
external createCompositeElementInternalHack
: (reactClass, Js.t({.. reasonProps : 'props}), array(reactElement)) => reactElement
= "createElement";
external add_nat: (int, int) => int = "add_nat_bytecode" "add_nat_native";
[@bs.module "Bar"] [@ocaml.deprecated "Use bar instead. It's a much cooler function. This string needs to be a little long"]
external foo : (bool) => bool = "";
/* Attributes on an entire polymorphic variant leaf */
[@bs.module "fs"]
external readFileSync : (
~name: string,
[@bs.string] [
| `utf8
[@bs.as "ascii"] | `my_name
]
) => string = "";
[@bs.module "fs"]
external readFileSync2 : (
~name: string,
[@bs.string] [
[@bs.as "ascii"] | `utf8
[@bs.as "ascii"] | `my_name
]) => string = "";
/* Ensure that attributes on extensions are printed */
[@test
[@attr]
[%%extension]
];
external debounce : (int, [@bs.meth] unit) => unit;
external debounce : (int, [@bs.meth] unit) => unit = "debounce";
external debounce : (int, [@bs.meth] unit) => unit = "";
external debounce : int => ([@bs.meth] (unit => unit)) = "";
external debounce : int => ([@bs.meth] (unit => unit)) => ([@bs.meth] (unit => unit)) = "";
external debounce : int => ([@bs.meth] (unit => unit)) => ([@bs.meth] (unit => unit)) => ([@bs.meth] (unit => unit)) = "";
external debounce : int => ([@bs.meth] (unit => unit)) => ([@bs.meth] (unit => [@bs.meth] (unit => unit))) => ([@bs.meth] (unit => unit)) = "";
let x = "hi";
let res = switch (x) {
| _ =>
[@attr]
{
open String;
open Array;
concat;
index_from;
}
};
let res = switch (x) {
| _ =>
[@attr]
{
open String;
open Array;
concat;
}
};
/* GADT */
type value =
| [@foo] VBool'(bool): [@bar] value
| VInt'(int): value;
/** Different payloads **/
/* Empty structure */
[@haha]
let x = 5;
/* Expression structure */
[@haha "hello world"]
let x = 5;
/* structure_item */
[@haha let x = 5]
let x = 5;
/* structure */
[@haha let x = 5; module X = {};]
let x = 5;
/* Pattern */
[@haha? Some(_) ]
let x = 5;
/* Type */
[@haha: option(int)]
let x = 5;
/* Record item attributes */
type t_ = {
/** Comment attribute on record item */
x: int
};
type tt = {
[@attr "on record field"]
x: int
};
type ttt = {
[@attr "on record field"]
x: [@attr "on type itself"] int
};
type tttt = {
/** Comment attribute on record item */
x: int,
[@regularAttribute "on next item"]
y: int
};
type ttttt = [@attr "moved to first row"] {
[@attr]
x: int
};
type tttttt = {
[@attr "testing with mutable field"]
mutable x: int
};
let tmp = {
/** On if statement */
if (true) {
true
} else {
false
};
};
type foo =
option(
[@foo ["how does this break", "when long enough"]] (
[@bar] (int => int),
[@baz] (int => int),
),
);
module Callbacks = {
let cb = () => 1 + 1;
};
let test = {
let _x = 1;
[@attr1]
open Callbacks;
let _s = "hello" ++ "!";
[@attr2] Callbacks.("hello" ++ "!");
};
[@test.call string => string]
let processCommandItem = 12;
module type Foo = { [@someattr] let foo: int => int;};
[@bs.deriving abstract]
type t = {
/** Position (in the pre-change coordinate system) where the change ended. */
[@bs.as "to"] [@bar]
to_: string,
};
[@bs.deriving abstract]
type editorConfiguration = {
[@bs.optional]
/** Determines whether horizontal cursor movement through right-to-left (Arabic, Hebrew) text
is visual (pressing the left arrow moves the cursor left)
or logical (pressing the left arrow moves to the next lower index in the string, which is visually right in right-to-left text).
The default is false on Windows, and true on other platforms. */
rtlMoveVisually: bool,
};
module Fmt = {
let barBaz = () => ();
type record = {x: int};
};
Fmt.([@foo] barBaz());
Fmt.([@foo] {x: 1});
Fmt.([@foo] [1, 2, 3]);
Fmt.([@foo] (1, 2, 3));
Fmt.([@foo] {val x = 10});
/**
* Attributes are associate with the identifier, function call, constructor
* appcation or constructor application pattern in front of it - up until a
* type constraint, an | (or) or an 'as'.
*/
let punnned_lbl_a = (~lbl as [@ATTR] lbl) => lbl;
let punnned_lbl_b = (~lbl as [@ATTR] (lbl: int)) => lbl;
let punnned_lbl_c = (~lbl as [@ATTR] ([@ATTR2] lbl)) => lbl;
let punnned_lbl_d = (~lbl as [@ATTR] ([@ATTR2] lbl: int)) => lbl;
let punnned_lbl_e = (~lbl as [@ATTR] ([@ATTR2] (lbl: int))) => lbl;
let punnned_lbl_f = (~lbl as [@ATTR] lbl: int) => lbl;
let punnned_lbl_g = (~lbl as ([@ATTR] lbl: int)) => lbl;
let punnned_lbl_h = (~lbl as ([@ATTR] (lbl: int))) => lbl;
/** Attributes have lower precedence than type constraint. The following should
* be printed identically. */
let punnned_lbl_i = (~lbl as [@ATTR] lbl: int) => lbl;
let punnned_lbl_i' = (~lbl as [@ATTR] (lbl: int)) => lbl;
let nonpunned_lbla = (~lbl as [@ATTR] lblNonpunned) => lblNonpunned;
let nonpunned_lbl_b = (~lbl as [@ATTR] (lblNonpunned: int)) => lblNonpunned;
let nonpunned_lbl_c = (~lbl as [@ATTR] ([@ATTR2] lblNonpunned)) => lblNonpunned;
let nonpunned_lbl_d = (~lbl as [@ATTR] ([@ATTR2] lblNonpunned: int)) => lblNonpunned;
let nonpunned_lbl_e = (~lbl as [@ATTR] ([@ATTR2] (lblNonpunned: int))) => lblNonpunned;
let nonpunned_lbl_f = (~lbl as [@ATTR] lblNonpunned: int) => lblNonpunned;
let nonpunned_lbl_g = (~lbl as ([@ATTR] lblNonpunned: int)) => lblNonpunned;
let nonpunned_lbl_h = (~lbl as ([@ATTR] (lblNonpunned: int))) => lblNonpunned;
let nonpunned_lbl_i = (~lbl as [@ATTR] lblNonpunned: int) => lblNonpunned;
let nonpunned_lbl_i' = (~lbl as [@ATTR] (lblNonpunned: int)) => lblNonpunned;
let defaulted_punnned_lbl_a = (~lbl as [@ATTR] lbl=0, ()) => lbl;
let defaulted_punnned_lbl_b = (~lbl as [@ATTR] (lbl: int)=0, ()) => lbl;
let defaulted_punnned_lbl_c = (~lbl as [@ATTR] ([@ATTR2] lbl)=0, ()) => lbl;
let defaulted_punnned_lbl_d = (~lbl as [@ATTR] ([@ATTR2] lbl: int)=0, ()) => lbl;
let defaulted_punnned_lbl_e = (~lbl as [@ATTR] ([@ATTR2] (lbl: int))=0, ()) => lbl;
let defaulted_punnned_lbl_f = (~lbl as [@ATTR] lbl: int=0, ()) => lbl;
let defaulted_punnned_lbl_g = (~lbl as ([@ATTR] lbl: int)=0, ()) => lbl;
let defaulted_punnned_lbl_h = (~lbl as ([@ATTR] (lbl: int))=0, ()) => lbl;
/** Attributes have lower precedence than type constraint. The following should
* be printed identically. */
let defaulted_punnned_lbl_i = (~lbl as [@ATTR] lbl: int=0, ()) => lbl;
let defaulted_punnned_lbl_i' = (~lbl as [@ATTR] (lbl: int)=0, ()) => lbl;
let defaulted_nonpunned_lbla = (~lbl as [@ATTR] lblNonpunned=0, ()) => lblNonpunned;
let defaulted_nonpunned_lbl_b = (~lbl as [@ATTR] (lblNonpunned: int)=0, ()) => lblNonpunned;
let defaulted_nonpunned_lbl_c = (~lbl as [@ATTR] ([@ATTR2] lblNonpunned)=0, ()) => lblNonpunned;
let defaulted_nonpunned_lbl_d = (~lbl as [@ATTR] ([@ATTR2] lblNonpunned: int)=0, ()) => lblNonpunned;
let defaulted_nonpunned_lbl_e = (~lbl as [@ATTR] ([@ATTR2] (lblNonpunned: int))=0, ()) => lblNonpunned;
let defaulted_nonpunned_lbl_f = (~lbl as [@ATTR] lblNonpunned: int=0, ()) => lblNonpunned;
let defaulted_nonpunned_lbl_g = (~lbl as ([@ATTR] lblNonpunned: int)=0, ()) => lblNonpunned;
let defaulted_nonpunned_lbl_h = (~lbl as ([@ATTR] (lblNonpunned: int))=0, ()) => lblNonpunned;
let defaulted_nonpunned_lbl_i = (~lbl as [@ATTR] lblNonpunned: int=0, ()) => lblNonpunned;
let defaulted_nonpunned_lbl_i' = (~lbl as [@ATTR] (lblNonpunned: int)=0, ()) => lblNonpunned;
/* Won't parse: let [@attr] x1 : int = xInt; */
let xInt = 0;
/**
Attribute on the pattern node inside of constraint
pattern (
Ppat_constraint(
pattern(@xxx, Ppat_var "x"),
coretype
)
)
This will get sugared to `let ([@attr] x2) : int = xInt`
*/
let ([@attr] x2 : int) = xInt;
/**
Attribute on the pattern holding the constraint:
pattern(
@xxx
Ppat_constraint(
pattern(Pexpident "x"),
coretype
)
)
*/
let ([@attr] (x3 : int)) = xInt;
let ([@attr] ([@attr0] x4: int)) = xInt;
let ([@attr] (([@attr0] x5): int)) = xInt;
type eitherOr('a, 'b) = Either('a) | Or('b);
let [@attr] Either(a) | Or(a) = Either("hi");
// Can drop the the parens around Either.
let ([@attr] Either(a)) | Or(a) = Either("hi");
// Can drop the parens around Or.
let Either(b) | ([@attr] Or(b)) = Either("hi");
// Should keep the parens around both
let [@attr] (Either(a) | Or(a)) = Either("hi");
// Should keep the parens
let [@attr] (_x as xAlias) = 10;
// Should drop the parens
let ([@attr] _x) as xAlias' = 10;
/**
Attribute on the expression node inside of constraint
expression(
Pexp_constraint(
expression(@xxx, Pexpident "x"),
coretype
)
)
*/
let _ = ([@xxx] xInt : int); // This should format the same
let _ = (([@xxx] xInt) : int); // This should format the same
/**
Attribute on the expression holding the constraint:
expression(
@xxx
Pexp_constraint(
expression(Pexpident "x"),
coretype
)
)
*/
let _ = [@xxx] (xInt : int); // This should format the same
[@foo? [@attr] (x: int)];
[@foo? [@attr] ([@bar] x: int)];
[@foo ? [@attr] (Either("hi") | Or("hi"))];
================================================
FILE: test/4.10/attributes-re.t/run.t
================================================
Format basic
$ refmt --print re ./input.re > ./formatted.re
Print the formatted file
$ cat ./formatted.re
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
/**
* Generally, dangling attributes [@..] apply to everything to the left of it,
* up until a comma, equals asignment, arrow, bar, or infix symbol (+/-) or
* prefix.
*
* This has a nice side effect when printing the terms:
* If a node has attributes attached to it,
*/;
/**Floating comment text should be removed*/;
/**
* Core language features:
* ----------------------
*/;
/**Floating doc text should be removed*/;
/**removed text on type def*/
[@itemAttributeOnTypeDef]
type itemText = int;
type nodeText =
/**removed text on item*/ int;
/**removed text on type def*/
[@itemAttributeOnTypeDef]
type nodeAndItemText =
/**removed text on item*/ int;
/**removed doc on type def*/
[@itemAttributeOnTypeDef]
type itemDoc = int;
[@itemAttributeOnTypeDef]
type nodeDoc =
/**removed text on item*/ int;
/**removed doc on type def*/
[@itemAttributeOnTypeDef]
type nodeAndItemDoc =
/**removed text on item*/ int;
[@itemAttributeOnTypeDef]
type x = int;
type attributedInt = [@onTopLevelTypeDef] int;
[@itemAttributeOnTypeDef]
type attributedIntsInTuple = (
[@onInt] int,
[@onFloat] float,
);
type myDataType('x, 'y) =
| MyDataType('x, 'y);
type myType =
[@onEntireType]
myDataType(
[@onOptionInt] option(int),
[@onOption] option(float),
);
let thisInst: myType =
[@attOnEntireDatatype]
MyDataType(Some(10), Some(10.0));
let thisInst: myType =
[@attOnEntireDatatype]
MyDataType(
[@onFirstParam] Some(10),
Some(10.0),
);
let x = [@onHello] "hello";
let x = [@onHello] "hello";
let x = "hello" ++ [@onGoodbye] "goodbye";
let x = [@onHello] "hello" ++ "goodbye";
let x = [@onHello] "hello" ++ "goodbye";
let x = "hello" ++ [@onGoodbye] "goodbye";
let x = [@onEverything] ("hello" ++ "goodbye");
let x = 10 + [@on20] 20;
let x = 10 + [@on20] 20;
let x = [@on10] 10 + 20;
let x = [@on10] 10 + 20;
let x = [@attrEverything] (10 + 20);
let x = 10 - [@on20] 20;
let x = 10 - [@on20] 20;
let x = [@on10] 10 - 20;
let x = [@on10] 10 - 20;
let x = [@attrEntireEverything] (10 - 20);
let x = true && [@onFalse] false;
let x = true && [@onFalse] false;
let x = [@onTrue] true && false;
let x = [@onTrue] true && false;
let x = [@attrEverything] (true && false);
/* now make sure to try with variants (tagged and `) */
/**
* How attribute parsings respond to other syntactic constructs.
*/
let add = a =>
[@onRet]
{
a;
};
let add = a => [@onRet] a;
let add = [@onEntireFunction] (a => a);
let res =
if (true) {false} else {[@onFalse] false};
let res =
[@onEntireIf] (if (true) {false} else {false});
let add = (a, b) =>
[@onEverything] ([@onA] a + b);
let add = (a, b) =>
[@onEverything] ([@onA] a + [@onB] b);
let add = (a, b) => a + [@onB] b;
let both = [@onEntireFunction] (a => a);
let both = (a, b) =>
[@onEverything] ([@onA] a && b);
let both = (a, b) =>
[@onA] a && [@onB] [@onB] b;
let both = (a, b) => [@onEverything] (a && b);
let thisVal = 10;
let x =
20
+ (- [@onFunctionCall] add(thisVal, thisVal));
let x =
[@onEverything]
(20 + (- add(thisVal, thisVal)));
let x =
- [@onFunctionCall] add(thisVal, thisVal);
let x =
[@onEverything] (- add(thisVal, thisVal));
let bothTrue = (x, y) => { contents: x && y };
let something =
[@onEverythingToRightOfEquals]
(bothTrue(true, true))^;
let something =
([@onlyOnArgumentToBang] bothTrue(true, true))
^;
let res =
[@appliesToEntireFunctionApplication]
add(2, 4);
[@appliesToEntireFunctionApplication]
add(2, 4);
let myObj = {
pub p = () => { pub z = () => 10 }
};
let result =
[@onSecondSend]
([@attOnFirstSend] myObj#p())#z();
[@onRecordFunctions]
type recordFunctions = {
p: unit => [@onUnit] recordFunctions,
q: [@onArrow] (unit => unit),
}
[@onUnusedType]
and unusedType = unit;
[@onMyRecord]
let rec myRecord = {
p: () => myRecord,
q: () => (),
}
[@onUnused]
and unused = ();
let result =
[@onSecondSend]
([@attOnFirstSend] myRecord.p()).q();
[@onVariantType]
type variantType =
| [@onInt] Foo(int)
| Bar([@onInt] int)
| Baz;
[@onVariantType]
type gadtType('x) =
| Foo(int): [@onFirstRow] gadtType(int)
| Bar([@onInt] int)
: [@onSecondRow] gadtType(unit)
| Baz: [@onThirdRow] gadtType([@onUnit] unit);
[@floatingTopLevelStructureItem hello];
[@itemAttributeOnEval]
print_string("hello");
[@itemAttrOnFirst]
let firstBinding = "first"
[@itemAttrOnSecond]
and secondBinding = "second";
/**
* Let bindings.
* ----------------------
*/
let showLets = () =>
[@onOuterLet]
{
let tmp = 20;
[@onFinalLet]
{
let tmpTmp = tmp + tmp;
tmpTmp + tmpTmp;
};
};
/**
* Classes:
* ------------
*/
/**
* In curried sugar, the class_expr attribute will apply to the return.
*/
[@moduleItemAttribute]
class boxA ('a) (init: 'a) =
[@onReturnClassExpr] {
/**Floating comment text should be removed*/;
/**Floating comment text should be removed*/;
pub pr = init + init + init;
};
/**
* In non-curried sugar, the class_expr still sticks to "the simple thing".
*/
class boxB ('a) (init: 'a) =
[@stillOnTheReturnBecauseItsSimple] {
pub pr = init + init + init;
};
/* To be able to put an attribute on just the return in that case, use
* parens. */
[@onBoxC
x;
y
]
class boxC ('a) =
[@onEntireFunction] (
fun (init: 'a) =>
[@onReturnClassExpr] {
pub pr = init + init + init;
}
);
[@moduleItemAttribute onTheTupleClassItem]
class tupleClass ('a, 'b) (init: ('a, 'b)) = {
let one = [@exprAttr ten] 10;
let two = [@exprAttr twenty] 20
and three = [@exprAttr thirty] 30;
[@pr prMember] pub pr = one + two + three;
};
[@structureItem]
class type addablePointClassType = {
/**Floating comment text should be removed*/;
/**Floating comment text should be removed*/;
pub x: int;
pub y: int;
pub add:
(
addablePointClassType,
addablePointClassType
) =>
int;
}
[@structureItem]
and anotherClassType = {
pub foo: int;
pub bar: int;
};
class type _x =
[@bs]
{
pub height: int;
};
class type _y = {
[@bs.set]
pub height: int;
};
[@attr]
class type _z = {
pub height: int;
};
module NestedModule = {
[@floatingNestedStructureItem hello];
};
[@structureItem]
module type HasAttrs = {
[@onTypeDef]
type t = int;
[@floatingNestedSigItem hello];
[@sigItem]
class type foo = {
pub foo: int;
pub bar: int;
};
[@sigItem]
class fooBar: (int) => foo;
/**Floating comment text should be removed*/;
/**Floating comment text should be removed*/;
};
type s =
| S(string);
let S([@onStr] str) = S([@onHello] "hello");
let [@onConstruction] S(str) =
[@onConstruction] S("hello");
type xy =
| X(string)
| Y(string);
let myFun =
(
[@onConstruction] X(hello) |
[@onConstruction] Y(hello),
) => hello;
let myFun =
(
X([@onHello] hello) | Y([@onHello] hello),
) => hello;
/* Another bug: Cannot have an attribute on or pattern
let myFun = fun ((X(hello) | Y(hello)) [@onOrPattern]) => hello;
*/
/* Melange FFI item attributes */
[@bs.val]
external imul: (int, int) => int = "Math.imul";
module Js = {
type t('a);
};
type classAttributesOnKeys = {
.
[@bs.set] key1: string,
/* The follow two are the same */
[@bs.get
{
null;
}
]
key2: [@onType2] Js.t(int),
[@bs.get
{
null;
}
]
key3: [@onType2] Js.t(int),
key4: Js.t([@justOnInt] int),
};
/* extensible variants */
type attr = ..;
[@block]
type attr +=
| [@tag1] [@tag2] Str
| [@tag3] Float;
type reconciler('props) = ..;
[@onVariantType]
type reconciler('props) +=
| Foo(int): [@onFirstRow] reconciler(int)
| Bar([@onInt] int): [@onSecondRow]
reconciler(unit)
| [@baz]
Baz: [@onThirdRow]
reconciler([@onUnit] unit);
type water = ..;
type water +=
pri
| [@foo] [@foo2] MineralWater
| SpringWater;
type cloud = string;
type water +=
pri
| [@h2o] PreparedWater
| [@nature] RainWater(cloud)
| [@toxic]
MeltedSnowWaterFromNuclearWastelandWithALineBreakBecauseTheNameIsSoLong;
/* reasonreact */
type element;
type reactElement;
type reactClass;
/* "react-dom" shouldn't spread the attribute over multiple lines */
[@bs.val] [@bs.module "react-dom"]
external render: (reactElement, element) => unit =
"render";
[@bs.module "f"] external f: int => int = "f";
[@bs.val] [@bs.module "react"] [@bs.splice]
external createCompositeElementInternalHack:
(
reactClass,
{.. "reasonProps": 'props },
array(reactElement)
) =>
reactElement =
"createElement";
external add_nat: (int, int) => int =
"add_nat_bytecode" "add_nat_native";
[@bs.module "Bar"]
[@ocaml.deprecated
"Use bar instead. It's a much cooler function. This string needs to be a little long"
]
external foo: bool => bool;
/* Attributes on an entire polymorphic variant leaf */
[@bs.module "fs"]
external readFileSync:
(
~name: string,
[@bs.string] [
| `utf8
| [@bs.as "ascii"] `my_name
]
) =>
string;
[@bs.module "fs"]
external readFileSync2:
(
~name: string,
[@bs.string] [
| [@bs.as "ascii"] `utf8
| [@bs.as "ascii"] `my_name
]
) =>
string;
/* Ensure that attributes on extensions are printed */
[@test [@attr] [%%extension]];
external debounce:
(int, [@bs.meth] unit) => unit;
external debounce: (int, [@bs.meth] unit) => unit =
"debounce";
external debounce:
(int, [@bs.meth] unit) => unit;
external debounce:
int => [@bs.meth] (unit => unit);
external debounce:
(int, [@bs.meth] (unit => unit)) =>
[@bs.meth] (unit => unit);
external debounce:
(
int,
[@bs.meth] (unit => unit),
[@bs.meth] (unit => unit)
) =>
[@bs.meth] (unit => unit);
external debounce:
(
int,
[@bs.meth] (unit => unit),
[@bs.meth] (
unit => [@bs.meth] (unit => unit)
)
) =>
[@bs.meth] (unit => unit);
let x = "hi";
let res =
switch (x) {
| _ =>
[@attr]
open String;
open Array;
concat;
index_from;
};
let res =
switch (x) {
| _ => [@attr] String.(Array.(concat))
};
/* GADT */
type value =
| [@foo] VBool'(bool): [@bar] value
| VInt'(int): value;
/** Different payloads **/
/* Empty structure */
[@haha]
let x = 5;
/* Expression structure */
[@haha "hello world"]
let x = 5;
/* structure_item */
[@haha let x = 5]
let x = 5;
/* structure */
[@haha
let x = 5;
module X = {}
]
let x = 5;
/* Pattern */
[@haha? Some(_)]
let x = 5;
/* Type */
[@haha: option(int)]
let x = 5;
/* Record item attributes */
type t_ = {
/** Comment attribute on record item */
x: int,
};
type tt = {
[@attr "on record field"]
x: int,
};
type ttt = {
[@attr "on record field"]
x: [@attr "on type itself"] int,
};
type tttt = {
/** Comment attribute on record item */
x: int,
[@regularAttribute "on next item"]
y: int,
};
type ttttt = {
[@attr "moved to first row"] [@attr]
x: int,
};
type tttttt = {
[@attr "testing with mutable field"]
mutable x: int,
};
let tmp =
/** On if statement */
(if (true) {true} else {false});
type foo =
option(
[@foo
[
"how does this break",
"when long enough",
]
] (
[@bar] (int => int),
[@baz] (int => int),
),
);
module Callbacks = {
let cb = () => 1 + 1;
};
let test = {
let _x = 1;
[@attr1]
open Callbacks;
let _s = "hello" ++ "!";
[@attr2] Callbacks.("hello" ++ "!");
};
[@test.call string => string]
let processCommandItem = 12;
module type Foo = {
[@someattr]
let foo: int => int;
};
[@bs.deriving abstract]
type t = {
/** Position (in the pre-change coordinate system) where the change ended. */
[@bs.as "to"] [@bar]
to_: string,
};
[@bs.deriving abstract]
type editorConfiguration = {
/** Determines whether horizontal cursor movement through right-to-left (Arabic, Hebrew) text
is visual (pressing the left arrow moves the cursor left)
or logical (pressing the left arrow moves to the next lower index in the string, which is visually right in right-to-left text).
The default is false on Windows, and true on other platforms. */
[@bs.optional]
rtlMoveVisually: bool,
};
module Fmt = {
let barBaz = () => ();
type record = {x: int};
};
Fmt.([@foo] barBaz());
Fmt.([@foo] { x: 1 });
Fmt.([@foo] [1, 2, 3]);
Fmt.([@foo] (1, 2, 3));
Fmt.([@foo] { val x = 10 });
/**
* Attributes are associate with the identifier, function call, constructor
* appcation or constructor application pattern in front of it - up until a
* type constraint, an | (or) or an 'as'.
*/
let punnned_lbl_a = (~lbl as [@ATTR] lbl) => lbl;
let punnned_lbl_b = (~lbl as [@ATTR] (lbl: int)) => lbl;
let punnned_lbl_c =
(~lbl as [@ATTR] [@ATTR2] lbl) => lbl;
let punnned_lbl_d =
(~lbl as [@ATTR] ([@ATTR2] lbl: int)) => lbl;
let punnned_lbl_e =
(~lbl as [@ATTR] [@ATTR2] (lbl: int)) => lbl;
let punnned_lbl_f = (~lbl as [@ATTR] lbl: int) => lbl;
let punnned_lbl_g = (~lbl as [@ATTR] lbl: int) => lbl;
let punnned_lbl_h = (~lbl as [@ATTR] (lbl: int)) => lbl;
/** Attributes have lower precedence than type constraint. The following should
* be printed identically. */
let punnned_lbl_i = (~lbl as [@ATTR] lbl: int) => lbl;
let punnned_lbl_i' =
(~lbl as [@ATTR] (lbl: int)) => lbl;
let nonpunned_lbla =
(~lbl as [@ATTR] lblNonpunned) => lblNonpunned;
let nonpunned_lbl_b =
(~lbl as [@ATTR] (lblNonpunned: int)) => lblNonpunned;
let nonpunned_lbl_c =
(~lbl as [@ATTR] [@ATTR2] lblNonpunned) => lblNonpunned;
let nonpunned_lbl_d =
(
~lbl as
[@ATTR] ([@ATTR2] lblNonpunned: int),
) => lblNonpunned;
let nonpunned_lbl_e =
(
~lbl as
[@ATTR] [@ATTR2] (lblNonpunned: int),
) => lblNonpunned;
let nonpunned_lbl_f =
(~lbl as [@ATTR] lblNonpunned: int) => lblNonpunned;
let nonpunned_lbl_g =
(~lbl as [@ATTR] lblNonpunned: int) => lblNonpunned;
let nonpunned_lbl_h =
(~lbl as [@ATTR] (lblNonpunned: int)) => lblNonpunned;
let nonpunned_lbl_i =
(~lbl as [@ATTR] lblNonpunned: int) => lblNonpunned;
let nonpunned_lbl_i' =
(~lbl as [@ATTR] (lblNonpunned: int)) => lblNonpunned;
let defaulted_punnned_lbl_a =
(~lbl as [@ATTR] lbl=0, ()) => lbl;
let defaulted_punnned_lbl_b =
(~lbl as [@ATTR] (lbl: int)=0, ()) => lbl;
let defaulted_punnned_lbl_c =
(~lbl as [@ATTR] [@ATTR2] lbl=0, ()) => lbl;
let defaulted_punnned_lbl_d =
(~lbl as [@ATTR] ([@ATTR2] lbl: int)=0, ()) => lbl;
let defaulted_punnned_lbl_e =
(~lbl as [@ATTR] [@ATTR2] (lbl: int)=0, ()) => lbl;
let defaulted_punnned_lbl_f =
(~lbl as [@ATTR] lbl: int=0, ()) => lbl;
let defaulted_punnned_lbl_g =
(~lbl as [@ATTR] lbl: int=0, ()) => lbl;
let defaulted_punnned_lbl_h =
(~lbl as [@ATTR] (lbl: int)=0, ()) => lbl;
/** Attributes have lower precedence than type constraint. The following should
* be printed identically. */
let defaulted_punnned_lbl_i =
(~lbl as [@ATTR] lbl: int=0, ()) => lbl;
let defaulted_punnned_lbl_i' =
(~lbl as [@ATTR] (lbl: int)=0, ()) => lbl;
let defaulted_nonpunned_lbla =
(~lbl as [@ATTR] lblNonpunned=0, ()) => lblNonpunned;
let defaulted_nonpunned_lbl_b =
(~lbl as [@ATTR] (lblNonpunned: int)=0, ()) => lblNonpunned;
let defaulted_nonpunned_lbl_c =
(
~lbl as [@ATTR] [@ATTR2] lblNonpunned=0,
(),
) => lblNonpunned;
let defaulted_nonpunned_lbl_d =
(
~lbl as [@ATTR] ([@ATTR2] lblNonpunned: int)=0,
(),
) => lblNonpunned;
let defaulted_nonpunned_lbl_e =
(
~lbl as [@ATTR] [@ATTR2] (lblNonpunned: int)=0,
(),
) => lblNonpunned;
let defaulted_nonpunned_lbl_f =
(~lbl as [@ATTR] lblNonpunned: int=0, ()) => lblNonpunned;
let defaulted_nonpunned_lbl_g =
(~lbl as [@ATTR] lblNonpunned: int=0, ()) => lblNonpunned;
let defaulted_nonpunned_lbl_h =
(~lbl as [@ATTR] (lblNonpunned: int)=0, ()) => lblNonpunned;
let defaulted_nonpunned_lbl_i =
(~lbl as [@ATTR] lblNonpunned: int=0, ()) => lblNonpunned;
let defaulted_nonpunned_lbl_i' =
(~lbl as [@ATTR] (lblNonpunned: int)=0, ()) => lblNonpunned;
/* Won't parse: let [@attr] x1 : int = xInt; */
let xInt = 0;
/**
Attribute on the pattern node inside of constraint
pattern (
Ppat_constraint(
pattern(@xxx, Ppat_var "x"),
coretype
)
)
This will get sugared to `let ([@attr] x2) : int = xInt`
*/
let (([@attr] x2): int) = xInt;
/**
Attribute on the pattern holding the constraint:
pattern(
@xxx
Ppat_constraint(
pattern(Pexpident "x"),
coretype
)
)
*/
let [@attr] (x3: int) = xInt;
let [@attr] ([@attr0] x4: int) = xInt;
let [@attr] ([@attr0] x5: int) = xInt;
type eitherOr('a, 'b) =
| Either('a)
| Or('b);
let [@attr] Either(a) | Or(a) = Either("hi");
// Can drop the the parens around Either.
let [@attr] Either(a) | Or(a) = Either("hi");
// Can drop the parens around Or.
let Either(b) | [@attr] Or(b) = Either("hi");
// Should keep the parens around both
let [@attr] (Either(a) | Or(a)) = Either("hi");
// Should keep the parens
let [@attr] (_x as xAlias) = 10;
// Should drop the parens
let [@attr] _x as xAlias' = 10;
/**
Attribute on the expression node inside of constraint
expression(
Pexp_constraint(
expression(@xxx, Pexpident "x"),
coretype
)
)
*/
let _ = ([@xxx] xInt: int); // This should format the same
let _ = ([@xxx] xInt: int); // This should format the same
/**
Attribute on the expression holding the constraint:
expression(
@xxx
Pexp_constraint(
expression(Pexpident "x"),
coretype
)
)
*/
let _ = [@xxx] (xInt: int); // This should format the same
[@foo? [@attr] (x: int)];
[@foo? [@attr] ([@bar] x: int)];
[@foo? [@attr] (Either("hi") | Or("hi"))];
Type-check basics
$ ocamlc -c -pp 'refmt --print binary' -intf-suffix .rei -impl formatted.re
File "formatted.re", line 507, characters 4-10:
507 | concat;
^^^^^^
Warning 10: this expression should have type unit.
Format the formatted file back
$ refmt --print re ./formatted.re > ./formatted_back.re
Ensure idempotency: first format and second format are the same
$ diff formatted.re formatted_back.re
================================================
FILE: test/4.10/dune
================================================
; Disable these tests in windows since their output don't match, and we
; want to ensure the output works in other systems
(cram
(enabled_if
(and
(or
(= %{system} "macosx")
(= %{system} "linux"))
(or
(= %{ocaml_version} 4.10.0)
(= %{ocaml_version} 4.10.1)
(= %{ocaml_version} 4.10.2)
(= %{ocaml_version} 4.10.3)))))
================================================
FILE: test/4.10/local-openings.t/input.ml
================================================
module Foo = struct
type t = { name: string }
end
let foo Foo.{name} = ()
let f = function
| Foo.{name} -> ()
| _ -> ()
let x = { Foo.name = "Reason" }
let Foo.{name} = x
let Foo.{name}, _ = x, ()
================================================
FILE: test/4.10/local-openings.t/run.t
================================================
Format basic
$ refmt --print re ./input.ml > ./formatted.re
Type-check basics
$ ocamlc -c -pp 'refmt --print binary' -intf-suffix .rei -impl formatted.re
File "formatted.re", line 10, characters 2-5:
10 | | _ => ();
^^^
Warning 11: this match case is unused.
Format the formatted file back
$ refmt --print re ./formatted.re > ./formatted_back.re
Ensure idempotency: first format and second format are the same
$ diff formatted.re formatted_back.re
================================================
FILE: test/4.10/reasonComments-re.t/input.re
================================================
3; /* - */
3 /*-*/
;
3/*-*/
;
3/*-*/;
/* **** comment */
/*** comment */
/** docstring */
/* comment */
/** docstring */
/*** comment */
/**** comment */
/***** comment */
/** */
/*** */
/**** */
/**/
/***/
/****/
/** (** comment *) */
/** (*** comment *) */
/* (** comment *) */
/* (*** comment *) */
/* *(*** comment *) */
/* comment **/
/* comment ***/
/* comment ****/
/* comment *****/
/**
* Multiline
*/
/** Multiline
*
*/
/**
**
*/
module JustString = {
include Map.Make(Int32); /* Comment eol include */
};
let testingEndOfLineComments =
[
"Item 1" /* Comment For First Item */,
"Item 2" /* Comment For Second Item */,
"Item 3" /* Comment For Third Item */,
"Item 4" /* Comment For Fourth Item - but before trailing comma */,
/* Comment after last item in list. */
] /* Comment after rbracket */;
/* But if you place them after the comma at eol, they're preserved as such */
let testingEndOfLineComments =
[
"Item 1", /* Comment For First Item */
"Item 2", /* Comment For Second Item */
"Item 3", /* Comment For Third Item */
"Item 4" /* Comment For Fourth Item - but before trailing comma */,
/* Comment after last item in list. */
] /* Comment after rbracket */ ;
/* The space between ; and comment shoudn't matter */
let testPlacementOfTrailingComment = [
"Item 0" /* */
/* Comment after last item in list. */
]; /* Comment after semi */
/* The space between ; and comment shoudn't matter */
let testPlacementOfTrailingComment = [
"Item 0" /* */
/* Comment after last item in list. */
];/* Comment after semi */
/* Try again but without other things in the list */
let testPlacementOfTrailingComment = [
"Item 0" /* */
]; /* Comment after semi */
/* The space between ; and comment shoudn't matter */
let testPlacementOfTrailingComment = [
"Item 0" /* */
/* Comment after last item in list. */
];/* Comment after semi */
let testingEndOfLineComments = [];/* Comment after entire let binding */
/* The following is not yet idempotent */
/* let myFunction */
/* withFirstArg /* First arg */ */
/* andSecondArg => { /* Second Arg */ */
/* withFirstArg + andSecondArg /* before semi */ ; */
/* }; */
let myFunction
(/* First arg */
withFirstArg,
/* Second Arg */
andSecondArg) {
withFirstArg + andSecondArg
}; /* After Semi */
type point = {
x: string, /* x field */
y: string, /* y field */
};
type pointWithManyKindsOfComments = {
/* Line before x */
x: string, /* x field */
/* Line before y */
y: string, /* y field */
/* Final row of record */
};
type typeParamPointWithComments('a) = {
/* Line before x */
x: 'a, /* x field */
/* Line before y */
y: 'a /* y field */
/* Final row of record */
};
/* Now, interleaving comments in type params */
type
/* Type name */
typeParamPointWithComments2(
/* The a type param */
'a,
/* The b type apram */
'b) = {
/* Line before x */
x: 'a, /* x field */
/* Line before y */
y: 'a /* y field */
/* Final row of record */
};
/* The way the last row comment is formatted is suboptimal becuase
* record type definitions do not include enough location information */
type anotherpoint = {
x: string, /* x field */
y: string, /* y field */
/* comment as last row of record */
};
type t = (int, int); /* End of line on t */
type t2 =
(int, int) /* End of line on (int, int) */
;
type t3 =
(int, int); /* End of line on (int, int) */
type variant =
| X (int, int) /* End of line on X */
| Y (int, int) /* End of line on Y */
; /* Comment on entire type def for variant */
/* Before let */
let res =
/* Before switch */
switch (X (2, 3)) {
/* Above X line */
| X(_) => "result of X" /* End of arrow and X line */
/* Above Y line */
| Y(_) => "result of Y" /* End of arrow and Y line */
}; /* After final semi in switch */
let res =
switch (X (2, 3)) {
| X (0, 0) => /* After X arrow */
"result of X" /* End of X body line */
| X (1, 0) /* Before X's arrow */ =>
"result of X" /* End of X body line */
| X (_) => /* After X _ arrow */
"result of X" /* End of X body line */
/* Above Y line */
| Y (_) =>
/* Comment above Y body */
"result of Y"
};
type variant2 =
/* Comment above X */
| X (int, int) /* End of line on X */
/* Comment above Y */
| Y (int, int);
type variant3 =
/* Comment above X */
| X (int, int) /* End of line on X */
/* Comment above Y */
| Y (int, int) /* End of line on Y */
;
type x = { /* not attached *above* x */
fieldOne : int,
fieldA : int
} /* Attached end of line after x */
and y = { /* not attached *above* y */
fieldTwo : int
} /* Attached end of line after y */
;
type x2 = { /* not attached *above* x2 */
fieldOne : int,
fieldA : int
} /* Attached end of line after x2 */
and y2 = { /* not attached *above* y2 */
fieldTwo : int
};
let result =
switch (None) {
| Some({fieldOne: 20, fieldA:a})=> /* Where does this comment go? */
let tmp = 0;
2 + tmp
| Some {fieldOne: n, fieldA:a} =>
/* How about this one */
let tmp = n;
n + tmp
| None => 20
};
let res =
/* Before switch */
switch (X (2, 3)) {
/* Above X line */
| X(_) => "result of X" /* End of arrow and X line */
/* Above Y line */
| Y(_) => "result of Y" /* End of arrow and Y line */
};
/*
* Now these end of line comments *should* be retained.
*/
let result = switch (None) {
| Some {
fieldOne: 20, /* end of line */
fieldA:a /* end of line */
} =>
let tmp = 0;
2 + tmp
| Some {
fieldOne: n, /* end of line */
fieldA:a /* end of line */
} =>
let tmp = n;
n + tmp
| None => 20
};
/*
* These end of line comments *should* be retained.
* To get the simple expression eol comment to be retained, we just need to
* implement label breaking eol behavior much like we did with sequences.
* Otherwise, right now they are not idempotent.
*/
let res =
switch ( /* Retain this */
X (2, 3)
)
{
/* Above X line */
| X (
_, /* retain this */
_ /* retain this */
) => "result of X"
/* Above Y line */
| Y(_) => "result of Y" /* End of arrow and Y line */
};
type optionalTuple =
| OptTup (
option ((
int, /* First int */
int /* Second int */
))
);
type optionTuple =
option ((
int, /* First int */
int /* Second int */
));
type intPair = (
int, /* First int */
int /* Second int */
);
type intPair2 = (
/* First int */
int,
/* Second int */
int
);
let result = {
/**/
(+)(2,3)
};
/* This is not yet idempotent */
/* { */
/* /**/ */
/* (+) 2 3 */
/* }; */
let a = ();
for (i in 0 to 10) {
/* bla */
a
};
if (true) {
/* hello */
()
};
type color =
| Red(int) /* After red end of line */
| Black(int) /* After black end of line */
| Green(int) /* After green end of line */
; /* On next line after color type def */
let blahCurriedX(x) =
fun
| Red(10)
| Black(20)
| Green(10) => 1 /* After or pattern green */
| Red(x) => 0 /* After red */
| Black(x) => 0 /* After black */
| Green(x) => 0 /* After second green */
; /* On next line after blahCurriedX def */
let name_equal(x,y) { x == y };
let equal(i1,i2) =
i1.contents === i2.contents && true; /* most unlikely first */
let equal(i1,i2) =
compare(compare(0,0),compare(1,1)); /* END OF LINE HERE */
let tuple_equal((i1, i2)) = i1 == i2;
let tuple_equal((csu, mgd)) =
/* Some really long comments, see https://github.com/facebook/reason/issues/811 */
tuple_equal((csu, mgd));
/** Comments inside empty function bodies
* See https://github.com/facebook/reason/issues/860
*/
let fun_def_comment_inline = () => { /* */ };
let fun_def_comment_newline = () => {
/* */
};
let fun_def_comment_long = () => { /* longer comment inside empty function body */};
let trueThing = true;
for (i in 0 to 1) {
/* comment */
print_newline();
};
while (trueThing) {
/* comment */
print_newline();
};
if (trueThing) {
/* comment */
print_newline()
};
/* Comment before if test */
if (trueThing) {
/* Comment before print */
print_newline();
/* Comment before print */
print_newline();
/* Comment after final print */
};
/* Comment before if test */
if (trueThing) {
/* Comment before print */
print_newline();
/* Comment after final print */
};
/* Comment before if test */
if (trueThing) {
/* Comment before print */
print_newline();
/* Comment before print */
print_newline();
/* Comment after final print */
} else {
/* Comment before print */
print_newline();
/* Comment before print */
print_newline();
/* Comment after final print */
};
/* Comment before if test */
if (trueThing) {
/* Comment before print */
print_newline();
/* Comment after final print */
} else {
/* Comment before print */
print_newline();
/* Comment after final print */
};
/* Comment before while test */
while (trueThing) {
/* Comment before print */
print_newline();
/* Comment before print */
print_newline();
/* Comment after final print */
};
/* Comment before while test */
while (trueThing) {
/* Comment before print */
print_newline();
/* Comment after final print */
};
/* Comment before for test */
for (i in 0 to 100) {
/* Comment before print */
print_newline();
/* Comment before print */
print_newline();
/* Comment after final print */
};
/* Comment before for test */
for (i in 0 to 100) {
/* Comment before print */
print_newline();
/* Comment after final print */
};
if (trueThing) {
/* Comment before print */
print_newline(); /* eol print */
/* Comment before print */
print_newline(); /* eol print */
/* Comment after print */
};
/* Comment before if test */
if (trueThing) {
/* Comment before print */
print_newline(); /* eol print */
/* Comment after print */
};
/* Comment before if test */
if (trueThing) {
/* Comment before print */
print_newline(); /* eol print */
/* Comment before print */
print_newline(); /* eol print */
/* Comment after print */
} else {
/* Comment before print */
print_newline(); /* eol print */
/* Comment before print */
print_newline(); /* eol print */
/* Comment after print */
};
/* Comment before if test */
if (trueThing) {
/* Comment before print */
print_newline(); /* eol print */
/* Comment before print */
} else {
/* Comment before print */
print_newline(); /* eol print */
/* Comment before print */
print_newline(); /* eol print */
/* Comment after print */
};
/* Comment before while test */
while (trueThing) {
/* Comment before print */
print_newline(); /* eol */
/* Comment before print */
print_newline(); /* eol */
/* Comment after final print */
};
/* Comment before while test */
while (trueThing) {
/* Comment before print */
print_newline(); /* eol */
/* Comment after final print */
};
/* Comment before for test */
for (i in 0 to 100) {
/* Comment before print */
print_newline(); /* eol */
/* Comment before print */
print_newline(); /* eol */
/* Comment after final print */
};
/* Comment before for test */
for (i in 0 to 100) {
/* Comment before print */
print_newline(); /* eol */
/* Comment after final print */
};
let f = (a, b, c, d) => a + b + c + d;
while(trueThing) {
f(
/* a */
1,
/* b */
2,
/* c */
3,
/* d */
4
/* does work */
);
};
while(trueThing) {
f(
/* a */
1,
/* b */
2,
/* c */
3,
/* d */
4 /* does work */
);
};
ignore((_really, _long, _printWidth, _exceeded, _here) => {
/* First comment */
let x = 0;
x + x;
/* Closing comment */
});
ignore((_xxx, _yyy) => {
/* First comment */
let x = 0;
x + x;
/* Closing comment */
});
type tester('a, 'b) = | TwoArgsConstructor('a, 'b) | OneTupleArgConstructor(('a, 'b));
let callFunctionTwoArgs = (a, b) => ();
let callFunctionOneTuple = (tuple) => ();
let y = TwoArgsConstructor(
1, /*eol1*/
2 /* eol2 */
);
let y = callFunctionTwoArgs(
1, /*eol1*/
2 /* eol2 */
);
let y = OneTupleArgConstructor((
1, /*eol1*/
2 /* eol2 */
));
let y = callFunctionOneTuple((
1, /*eol1*/
2 /* eol2 */
));
type polyRecord('a, 'b) = {fieldOne: 'a, fieldTwo: 'b};
let r = {
fieldOne: 1, /*eol1*/
fieldTwo: 2 /* eol2 */
};
let r = {
fieldOne: 1, /*eol1*/
fieldTwo: 2, /* eol2 with trailing comma */
};
let y = TwoArgsConstructor(
"1", /*eol1*/
"2" /* eol2 */
);
let y = callFunctionTwoArgs(
"1", /*eol1*/
"2" /* eol2 */
);
let y = OneTupleArgConstructor((
"1", /*eol1*/
"2" /* eol2 */
));
let y = callFunctionOneTuple((
"1", /*eol1*/
"2" /* eol2 */
));
let r = {
fieldOne: "1", /*eol1*/
fieldTwo: "2" /* eol2 */
};
let r = {
fieldOne: "1", /*eol1*/
fieldTwo: "2", /* eol2 with trailing comma */
};
let identifier = "hello";
let y = TwoArgsConstructor(
identifier, /*eol1*/
identifier /* eol2 */
);
let y = callFunctionTwoArgs(
identifier , /*eol1*/
identifier /* eol2 */
);
let y = OneTupleArgConstructor((
identifier , /*eol1*/
identifier /* eol2 */
));
let y = callFunctionOneTuple((
identifier , /*eol1*/
identifier /* eol2 */
));
let r = {
fieldOne: identifier, /*eol1*/
fieldTwo: identifier /* eol2 */
};
let r = {
fieldOne: identifier, /*eol1*/
fieldTwo: identifier, /* eol2 with trailing comma */
};
let y = TwoArgsConstructor(
identifier : string, /*eol1*/
identifier : string/* eol2 */
);
let y = callFunctionTwoArgs(
identifier : string , /*eol1*/
identifier : string /* eol2 */
);
let y = OneTupleArgConstructor((
identifier : string , /*eol1*/
identifier : string /* eol2 */
));
let y = callFunctionOneTuple((
identifier : string , /*eol1*/
identifier : string /* eol2 */
));
let r = {
fieldOne: (identifier : string), /*eol1*/
fieldTwo: (identifier : string) /* eol2 */
};
let r = {
fieldOne: (identifier : string), /*eol1*/
fieldTwo: (identifier : string), /* eol2 with trailing comma */
};
/** doc comment */
[@bs.send]
external url : t => string = "";
/**
* Short multiline doc comment
*/
[@bs.send]
external url : t => string = "";
/** Longer doc comment before an attribute on an external. */
[@bs.send]
external url : t => string = "";
/* normal comment */
[@bs.send] external url : t => string = "";
/** doc type */
type q = {a: int, b: string};
/** doc let */
let letter : q = {a: 42, b: "answer"};
================================================
FILE: test/4.10/reasonComments-re.t/run.t
================================================
Format basic
$ refmt --print re ./input.re > ./formatted.re
Print the formatted file
$ cat ./formatted.re
3; /* - */
3; /*-*/
3; /*-*/
3 /*-*/;
/* **** comment */
/*** comment */
/** docstring */
/* comment */
/** docstring */
/*** comment */
/**** comment */
/***** comment */
/** */
/*** */
/**** */
/**/
/***/
/****/
/** (** comment *) */
/** (*** comment *) */
/* (** comment *) */
/* (*** comment *) */
/* *(*** comment *) */
/* comment **/
/* comment ***/
/* comment ****/
/* comment *****/
/**
* Multiline
*/
/** Multiline
*
*/
/**
**
*/
module JustString = {
include Map.Make(Int32); /* Comment eol include */
};
let testingEndOfLineComments = [
"Item 1" /* Comment For First Item */,
"Item 2" /* Comment For Second Item */,
"Item 3" /* Comment For Third Item */,
"Item 4" /* Comment For Fourth Item - but before trailing comma */,
/* Comment after last item in list. */
] /* Comment after rbracket */;
/* But if you place them after the comma at eol, they're preserved as such */
let testingEndOfLineComments = [
"Item 1", /* Comment For First Item */
"Item 2", /* Comment For Second Item */
"Item 3", /* Comment For Third Item */
"Item 4" /* Comment For Fourth Item - but before trailing comma */,
/* Comment after last item in list. */
] /* Comment after rbracket */;
/* The space between ; and comment shoudn't matter */
let testPlacementOfTrailingComment = [
"Item 0" /* */
/* Comment after last item in list. */
]; /* Comment after semi */
/* The space between ; and comment shoudn't matter */
let testPlacementOfTrailingComment = [
"Item 0" /* */
/* Comment after last item in list. */
]; /* Comment after semi */
/* Try again but without other things in the list */
let testPlacementOfTrailingComment = [
"Item 0" /* */
]; /* Comment after semi */
/* The space between ; and comment shoudn't matter */
let testPlacementOfTrailingComment = [
"Item 0" /* */
/* Comment after last item in list. */
]; /* Comment after semi */
let testingEndOfLineComments = []; /* Comment after entire let binding */
/* The following is not yet idempotent */
/* let myFunction */
/* withFirstArg /* First arg */ */
/* andSecondArg => { /* Second Arg */ */
/* withFirstArg + andSecondArg /* before semi */ ; */
/* }; */
let myFunction = /* First arg */
(
withFirstArg,
/* Second Arg */
andSecondArg,
) => {
withFirstArg + andSecondArg;
}; /* After Semi */
type point = {
x: string, /* x field */
y: string /* y field */
};
type pointWithManyKindsOfComments = {
/* Line before x */
x: string, /* x field */
/* Line before y */
y: string /* y field */
/* Final row of record */
};
type typeParamPointWithComments('a) = {
/* Line before x */
x: 'a, /* x field */
/* Line before y */
y: 'a /* y field */
/* Final row of record */
};
/* Now, interleaving comments in type params */
/* Type name */
type typeParamPointWithComments2
/* The a type param */
(
'a,
/* The b type apram */
'b,
) = {
/* Line before x */
x: 'a, /* x field */
/* Line before y */
y: 'a /* y field */
/* Final row of record */
};
/* The way the last row comment is formatted is suboptimal becuase
* record type definitions do not include enough location information */
type anotherpoint = {
x: string, /* x field */
y: string /* y field */
/* comment as last row of record */
};
type t = (int, int); /* End of line on t */
type t2 = (int, int); /* End of line on (int, int) */
type t3 = (int, int); /* End of line on (int, int) */
type variant =
| X(int, int) /* End of line on X */
| Y(int, int); /* End of line on Y */ /* Comment on entire type def for variant */
/* Before let */
let res =
/* Before switch */
switch (X(2, 3)) {
/* Above X line */
| X(_) => "result of X" /* End of arrow and X line */
/* Above Y line */
| Y(_) => "result of Y" /* End of arrow and Y line */
}; /* After final semi in switch */
let res =
switch (X(2, 3)) {
| X(0, 0) =>
/* After X arrow */
"result of X" /* End of X body line */
| X(1, 0) /* Before X's arrow */ => "result of X" /* End of X body line */
| X(_) =>
/* After X _ arrow */
"result of X" /* End of X body line */
/* Above Y line */
| Y(_) =>
/* Comment above Y body */
"result of Y"
};
type variant2 =
/* Comment above X */
| X(int, int) /* End of line on X */
/* Comment above Y */
| Y(int, int);
type variant3 =
/* Comment above X */
| X(int, int) /* End of line on X */
/* Comment above Y */
| Y(int, int); /* End of line on Y */
type x = {
/* not attached *above* x */
fieldOne: int,
fieldA: int,
} /* Attached end of line after x */
and y = {
/* not attached *above* y */
fieldTwo: int,
}; /* Attached end of line after y */
type x2 = {
/* not attached *above* x2 */
fieldOne: int,
fieldA: int,
} /* Attached end of line after x2 */
and y2 = {
/* not attached *above* y2 */
fieldTwo: int,
};
let result =
switch (None) {
| Some({ fieldOne: 20, fieldA: a }) =>
/* Where does this comment go? */
let tmp = 0;
2 + tmp;
| Some({ fieldOne: n, fieldA: a }) =>
/* How about this one */
let tmp = n;
n + tmp;
| None => 20
};
let res =
/* Before switch */
switch (X(2, 3)) {
/* Above X line */
| X(_) => "result of X" /* End of arrow and X line */
/* Above Y line */
| Y(_) => "result of Y" /* End of arrow and Y line */
};
/*
* Now these end of line comments *should* be retained.
*/
let result =
switch (None) {
| Some({
fieldOne: 20, /* end of line */
fieldA: a /* end of line */
}) =>
let tmp = 0;
2 + tmp;
| Some({
fieldOne: n, /* end of line */
fieldA: a /* end of line */
}) =>
let tmp = n;
n + tmp;
| None => 20
};
/*
* These end of line comments *should* be retained.
* To get the simple expression eol comment to be retained, we just need to
* implement label breaking eol behavior much like we did with sequences.
* Otherwise, right now they are not idempotent.
*/
let res =
switch (
/* Retain this */
X(2, 3)
) {
/* Above X line */
| X(
_, /* retain this */
_ /* retain this */
) => "result of X"
/* Above Y line */
| Y(_) => "result of Y" /* End of arrow and Y line */
};
type optionalTuple =
| OptTup(
option(
(
int, /* First int */
int /* Second int */
),
),
);
type optionTuple =
option(
(
int, /* First int */
int /* Second int */
),
);
type intPair = (
int, /* First int */
int /* Second int */
);
type intPair2 = (
/* First int */
int,
/* Second int */
int,
);
let result =
/**/
{
2 + 3;
};
/* This is not yet idempotent */
/* { */
/* /**/ */
/* (+) 2 3 */
/* }; */
let a = ();
for (i in 0 to 10) {
/* bla */
a;
};
if (true) {
/* hello */
()
};
type color =
| Red(int) /* After red end of line */
| Black(int) /* After black end of line */
| Green(int); /* After green end of line */ /* On next line after color type def */
let blahCurriedX = x =>
fun
| Red(10)
| Black(20)
| Green(10) => 1 /* After or pattern green */
| Red(x) => 0 /* After red */
| Black(x) => 0 /* After black */
| Green(x) => 0; /* After second green */ /* On next line after blahCurriedX def */
let name_equal = (x, y) => {
x == y;
};
let equal = (i1, i2) =>
i1.contents === i2.contents && true; /* most unlikely first */
let equal = (i1, i2) =>
compare(compare(0, 0), compare(1, 1)); /* END OF LINE HERE */
let tuple_equal = ((i1, i2)) => i1 == i2;
let tuple_equal = ((csu, mgd)) =>
/* Some really long comments, see https://github.com/facebook/reason/issues/811 */
tuple_equal((csu, mgd));
/** Comments inside empty function bodies
* See https://github.com/facebook/reason/issues/860
*/
let fun_def_comment_inline = () => {/* */};
let fun_def_comment_newline = () => {/* */};
let fun_def_comment_long = () => {
/* longer comment inside empty function body */
};
let trueThing = true;
for (i in 0 to 1) {
/* comment */
print_newline();
};
while (trueThing) {
/* comment */
print_newline();
};
if (trueThing) {
/* comment */
print_newline();
};
/* Comment before if test */
if (trueThing) {
/* Comment before print */
print_newline();
/* Comment before print */
print_newline();
/* Comment after final print */
};
/* Comment before if test */
if (trueThing) {
/* Comment before print */
print_newline();
/* Comment after final print */
};
/* Comment before if test */
if (trueThing) {
/* Comment before print */
print_newline();
/* Comment before print */
print_newline();
/* Comment after final print */
} else {
/* Comment before print */
print_newline();
/* Comment before print */
print_newline();
/* Comment after final print */
};
/* Comment before if test */
if (trueThing) {
/* Comment before print */
print_newline();
/* Comment after final print */
} else {
/* Comment before print */
print_newline();
/* Comment after final print */
};
/* Comment before while test */
while (trueThing) {
/* Comment before print */
print_newline();
/* Comment before print */
print_newline();
/* Comment after final print */
};
/* Comment before while test */
while (trueThing) {
/* Comment before print */
print_newline();
/* Comment after final print */
};
/* Comment before for test */
for (i in 0 to 100) {
/* Comment before print */
print_newline();
/* Comment before print */
print_newline();
/* Comment after final print */
};
/* Comment before for test */
for (i in 0 to 100) {
/* Comment before print */
print_newline();
/* Comment after final print */
};
if (trueThing) {
/* Comment before print */
print_newline(); /* eol print */
/* Comment before print */
print_newline(); /* eol print */
/* Comment after print */
};
/* Comment before if test */
if (trueThing) {
/* Comment before print */
print_newline(); /* eol print */
/* Comment after print */
};
/* Comment before if test */
if (trueThing) {
/* Comment before print */
print_newline(); /* eol print */
/* Comment before print */
print_newline(); /* eol print */
/* Comment after print */
} else {
/* Comment before print */
print_newline(); /* eol print */
/* Comment before print */
print_newline(); /* eol print */
/* Comment after print */
};
/* Comment before if test */
if (trueThing) {
/* Comment before print */
print_newline(); /* eol print */
/* Comment before print */
} else {
/* Comment before print */
print_newline(); /* eol print */
/* Comment before print */
print_newline(); /* eol print */
/* Comment after print */
};
/* Comment before while test */
while (trueThing) {
/* Comment before print */
print_newline(); /* eol */
/* Comment before print */
print_newline(); /* eol */
/* Comment after final print */
};
/* Comment before while test */
while (trueThing) {
/* Comment before print */
print_newline(); /* eol */
/* Comment after final print */
};
/* Comment before for test */
for (i in 0 to 100) {
/* Comment before print */
print_newline(); /* eol */
/* Comment before print */
print_newline(); /* eol */
/* Comment after final print */
};
/* Comment before for test */
for (i in 0 to 100) {
/* Comment before print */
print_newline(); /* eol */
/* Comment after final print */
};
let f = (a, b, c, d) => a + b + c + d;
while (trueThing) {
f(
/* a */
1,
/* b */
2,
/* c */
3,
/* d */
4,
/* does work */
);
};
while (trueThing) {
f(
/* a */
1,
/* b */
2,
/* c */
3,
/* d */
4 /* does work */
);
};
ignore(
(
_really,
_long,
_printWidth,
_exceeded,
_here,
) => {
/* First comment */
let x = 0;
x + x;
/* Closing comment */
});
ignore((_xxx, _yyy) => {
/* First comment */
let x = 0;
x + x;
/* Closing comment */
});
type tester('a, 'b) =
| TwoArgsConstructor('a, 'b)
| OneTupleArgConstructor(('a, 'b));
let callFunctionTwoArgs = (a, b) => ();
let callFunctionOneTuple = tuple => ();
let y =
TwoArgsConstructor(
1, /*eol1*/
2 /* eol2 */
);
let y =
callFunctionTwoArgs(
1, /*eol1*/
2 /* eol2 */
);
let y =
OneTupleArgConstructor((
1, /*eol1*/
2 /* eol2 */
));
let y =
callFunctionOneTuple((
1, /*eol1*/
2 /* eol2 */
));
type polyRecord('a, 'b) = {
fieldOne: 'a,
fieldTwo: 'b,
};
let r = {
fieldOne: 1, /*eol1*/
fieldTwo: 2 /* eol2 */
};
let r = {
fieldOne: 1, /*eol1*/
fieldTwo: 2 /* eol2 with trailing comma */
};
let y =
TwoArgsConstructor(
"1", /*eol1*/
"2" /* eol2 */
);
let y =
callFunctionTwoArgs(
"1", /*eol1*/
"2" /* eol2 */
);
let y =
OneTupleArgConstructor((
"1", /*eol1*/
"2" /* eol2 */
));
let y =
callFunctionOneTuple((
"1", /*eol1*/
"2" /* eol2 */
));
let r = {
fieldOne: "1", /*eol1*/
fieldTwo: "2" /* eol2 */
};
let r = {
fieldOne: "1", /*eol1*/
fieldTwo: "2" /* eol2 with trailing comma */
};
let identifier = "hello";
let y =
TwoArgsConstructor(
identifier, /*eol1*/
identifier /* eol2 */
);
let y =
callFunctionTwoArgs(
identifier, /*eol1*/
identifier /* eol2 */
);
let y =
OneTupleArgConstructor((
identifier, /*eol1*/
identifier /* eol2 */
));
let y =
callFunctionOneTuple((
identifier, /*eol1*/
identifier /* eol2 */
));
let r = {
fieldOne: identifier, /*eol1*/
fieldTwo: identifier /* eol2 */
};
let r = {
fieldOne: identifier, /*eol1*/
fieldTwo: identifier /* eol2 with trailing comma */
};
let y =
TwoArgsConstructor(
identifier: string, /*eol1*/
identifier: string /* eol2 */
);
let y =
callFunctionTwoArgs(
identifier: string, /*eol1*/
identifier: string /* eol2 */
);
let y =
OneTupleArgConstructor((
identifier: string, /*eol1*/
identifier: string /* eol2 */
));
let y =
callFunctionOneTuple((
identifier: string, /*eol1*/
identifier: string /* eol2 */
));
let r = {
fieldOne: (identifier: string), /*eol1*/
fieldTwo: (identifier: string) /* eol2 */
};
let r = {
fieldOne: (identifier: string), /*eol1*/
fieldTwo: (identifier: string) /* eol2 with trailing comma */
};
/** doc comment */
[@bs.send]
external url: t => string;
/**
* Short multiline doc comment
*/
[@bs.send]
external url: t => string;
/** Longer doc comment before an attribute on an external. */
[@bs.send]
external url: t => string;
/* normal comment */
[@bs.send] external url: t => string;
/** doc type */
type q = {
a: int,
b: string,
};
/** doc let */
let letter: q = {
a: 42,
b: "answer",
};
Type-check basics
$ ocamlc -c -pp 'refmt --print binary' -intf-suffix .rei -impl formatted.re
File "formatted.re", lines 536-548, characters 18-1:
536 | ..................{
537 | f(
538 | /* a */
539 | 1,
540 | /* b */
...
545 | 4,
546 | /* does work */
547 | );
548 | }.
Warning 10: this expression should have type unit.
File "formatted.re", lines 549-560, characters 18-1:
549 | ..................{
550 | f(
551 | /* a */
552 | 1,
553 | /* b */
...
557 | /* d */
558 | 4 /* does work */
559 | );
560 | }.
Warning 10: this expression should have type unit.
Format the formatted file back
$ refmt --print re ./formatted.re > ./formatted_back.re
Ensure idempotency: first format and second format are the same
$ diff formatted.re formatted_back.re
================================================
FILE: test/4.10/type-jsx.t/input.re
================================================
type component = {displayName: string};
module Bar = {
let createElement(~c=?,~children,()) {displayName: "test"};
};
module Nesting = {
let createElement(~children,()) {displayName: "test"};
};
module Much = {
let createElement(~children,()) {displayName: "test"};
};
module Foo = {
let createElement(~a=?,~b=?,~children,()) {displayName: "test"};
};
module One = {
let createElement(~test=?,~foo=?,~children,()) {displayName: "test"};
let createElementobvioustypo(~test,~children,()) {displayName: "test"};
};
module Two = {
let createElement(~foo=?,~children,()) {displayName: "test"};
};
module Sibling = {
let createElement(~foo=?,~children : list(component),()) = {displayName: "test"};
};
module Test = {
let createElement(~yo=?,~children,()) {displayName: "test"};
};
module So = {
let createElement(~children,()) {displayName: "test"};
};
module Foo2 = {
let createElement(~children,()) {displayName: "test"};
};
module Text = {
let createElement(~children,()) {displayName: "test"};
};
module Exp = {
let createElement(~children,()) {displayName: "test"};
};
module Pun = {
let createElement(~intended=?,~children,()) {displayName: "test"};
};
module Namespace = {
module Foo = {
let createElement(~intended=?,~anotherOptional as x=100,~children,()) {displayName: "test"};
};
};
module Optional1 = {
let createElement(~required,~children,()) {
switch (required) {
| Some(a) => {displayName: a}
| None => {displayName: "nope"}
};
};
};
module Optional2 = {
let createElement(~optional=?,~children,()) {
switch (optional) {
| Some(a) => {displayName: a}
| None => {displayName: "nope"}
};
};
};
module DefaultArg = {
let createElement(~default=Some("foo"),~children,()) {
switch (default) {
| Some(a) => {displayName: a}
| None => {displayName: "nope"}
};
};
};
module LotsOfArguments = {
let createElement(~argument1=?,~argument2=?,~argument3=?,~argument4=?,~argument5=?,~argument6=?,~children,()) {displayName: "test"};
};
let div(~argument1=?,~children,()) {
displayName: "test"
};
module List1 = {
let createElement(~children,()) {displayName: "test"};
};
module List2 = {
let createElement(~children,()) {displayName: "test"};
};
module List3 = {
let createElement(~children,()) {displayName: "test"};
};
module NotReallyJSX = {
let createElement(~foo,~bar,children) {displayName: "test"};
};
let notReallyJSX(~foo,~bar,children) {
displayName: "test"
};
let fakeRender (el:component) {
el.displayName
};
/* end of setup */
let (/><)(a,b) = a + b;
let (><)(a,b) = a + b;
let (/>) = fun(a,b) => a + b;
let ( ><\/ ) = fun(a,b) => a + b;
let tag1 = 5 />< 6;
let tag2 = 5 >< 7;
let tag3 = 5 /> 7;
let tag4 = 5 ><\/ 7;
let b = 2;
let selfClosing = <Foo />;
let selfClosing2 = <Foo a=1 b=true />;
let selfClosing3 =
<Foo
a="really long values that should"
b="cause the entire thing to wrap"
/>;
let a = <Foo> <Bar c=((a) => a + 2) /> </Foo>;
let a3 = <So> <Much> <Nesting> </Nesting> </Much> </So>;
let a4 = <Sibling> <One test=true foo=b /> <Two foo=b> </Two> </Sibling>;
let a5 = <Foo>"testing a string here"</Foo>;
let a6 =
<Foo2>
<Text>
"testing a string here"</Text>
<Test yo=1 /> <Text>"another string"</Text> <Bar> </Bar> <Exp>( 2 + 4 )</Exp>
</Foo2>;
let intended = true;
let punning = <Pun intended />;
let namespace = <Namespace.Foo />;
let c = <Foo> </Foo>;
let d = <Foo> </Foo>;
let spaceBefore = <So> <Much> <Nesting> </Nesting> </Much> </So>;
let spaceBefore2 = <So> <Much/> </So>;
let siblingNotSpaced = <So> <Much> </Much> <Much> </Much> </So>;
let jsxInList = [ <Foo> </Foo>];
let jsxInList2 = [ <Foo />];
let jsxInListA = [ <Foo> </Foo> ];
let jsxInListB = [ <Foo /> ];
let jsxInListC = [ <Foo> </Foo>];
let jsxInListD = [ <Foo />];
let jsxInList3 = [ <Foo> </Foo>, <Foo> </Foo>, <Foo> </Foo>];
let jsxInList4 = [ <Foo />, <Foo />, <Foo />];
let jsxInList5 = [ <Foo> </Foo>, <Foo> </Foo> ];
let jsxInList6 = [ <Foo />, <Foo /> ];
let jsxInList7 = [ <Foo> </Foo>, <Foo> </Foo>];
let jsxInList8 = [ <Foo />, <Foo />];
let testFunc(b) = b;
let jsxInFnCall = testFunc (<Foo />);
let lotsOfArguments = <LotsOfArguments argument1=1 argument2=2 argument3=3 argument4=4 argument5=5 argument6="test"> <Namespace.Foo /> </LotsOfArguments>;
let lowerCase = <div argument1=1 />;
let b = 0;
let d = 0;
/*
* Should pun the first example:
*/
let a = <Foo a=a>5</Foo>;
let a = <Foo a=b>5</Foo>;
let a = <Foo a=b b=d>5</Foo>;
let a = <Foo a>0.55</Foo>;
let a = [@JSX] Foo.createElement(~children=[],());
let ident = <Foo>{a}</Foo>;
let fragment1 = <> <Foo /> <Foo /> </>;
let fragment2 = <> <Foo /> <Foo /> </>;
let fragment3 = <> <Foo /> <Foo /> </>;
let fragment4 = <> <Foo /> <Foo /> </>;
let fragment5 = <> <Foo> </Foo> <Foo> </Foo> </>;
let fragment6 = <> <Foo> </Foo> <Foo> </Foo> </>;
let fragment7 = <> <Foo> </Foo> <Foo> </Foo> </>;
let fragment8 = <> <Foo> </Foo> <Foo> </Foo> </>;
let fragment9 = <> 2 2 2 2 </>;
let fragment10 = <>2.2 3.2 4.6 1.2 </>;
let fragment11 = <>"str"</>;
let fragment12 = <>(6 + 2) (6 + 2) (6 + 2)</>;
let fragment13 = <>fragment11 fragment11</>;
let listOfItems1 = <List1>1 2 3 4 5</List1>;
let listOfItems2 = <List2>1.0 2.8 3.8 4.0 5.1</List2>;
let listOfItems3 = <List3>fragment11 fragment11</List3>;
/*
* Several sequential simple jsx expressions must be separated with a space.
*/
let thisIsRight(a,b) = ();
let tagOne = fun(~children,()) => ();
let tagTwo = fun(~children,()) => ();
/* thisIsWrong <tagOne /><tagTwo />; */
thisIsRight(<tagOne />,<tagTwo />);
/* thisIsWrong <tagOne> </tagOne><tagTwo> </tagTwo>; */
thisIsRight(<tagOne> </tagOne>, <tagTwo> </tagTwo>);
let a = fun(~children,()) => ();
let b = fun(~children,()) => ();
let thisIsOkay =
<List1>
<a> </a> <b> </b>
<a/> <b/>
</List1>;
let thisIsAlsoOkay =
<List1>
<a> </a> <b> </b>
</List1>;
/* Doesn't make any sense, but suppose you defined an
infix operator to compare jsx */
<a /> < <b />;
<a /> > <b />;
<a> </a> < <b> </b>;
<a> </a> > <b> </b>;
let listOfListOfJsx = [<> </>];
let listOfListOfJsx = [<> <Foo> </Foo> </>];
let listOfListOfJsx = [<> <Foo /> </>, <> <Bar /> </> ];
let listOfListOfJsx = [<> <Foo /> </>, <> <Bar /> </>, ...listOfListOfJsx];
let sameButWithSpaces = [ <> </>];
let sameButWithSpaces = [ <> <Foo /> </>];
let sameButWithSpaces = [ <> <Foo /> </>, <> <Bar /> </>];
let sameButWithSpaces = [ <> <Foo /> </>, <> <Bar /> </>, ...sameButWithSpaces];
/*
* Test named tag right next to an open bracket.
*/
let listOfJsx = [];
let listOfJsx = [<Foo> </Foo>];
let listOfJsx = [<Foo />, <Bar /> ];
let listOfJsx = [<Foo />, <Bar /> , ...listOfJsx];
let sameButWithSpaces = [];
let sameButWithSpaces = [<Foo />];
let sameButWithSpaces = [<Foo />, <Bar />];
let sameButWithSpaces = [<Foo />, <Bar />, ...sameButWithSpaces];
/**
* Test no conflict with polymorphic variant types.
*/
type thisType = [`Foo | `Bar];
type t('a) = [< thisType ] as 'a;
let asd = [@JSX] [@foo] One.createElement(~test=true, ~foo=2, ~children=["a", "b"],());
let asd2 = [@JSX] [@foo] One.createElementobvioustypo(~test=false, ~children=["a", "b"],());
let span(~test : bool,~foo : int,~children,()) = 1;
let asd = [@JSX] [@foo] span(~test=true, ~foo=2, ~children=["a", "b"],());
/* "video" call doesn't end with a list, so the expression isn't converted to JSX */
let video(~test: bool,children) = children;
let asd2 = [@JSX] [@foo] video(~test=false,10);
let div(~children) = 1;
([@JSX] (((fun () => div) ())(~children=[])));
let myFun () {
<>
<Namespace.Foo intended=(true) anotherOptional=200 />
<Namespace.Foo intended=(true) anotherOptional=200 />
<Namespace.Foo intended=(true) anotherOptional=200>
<Foo />
<Foo />
<Foo />
<Foo />
<Foo />
<Foo />
<Foo />
</Namespace.Foo>
</>;
};
let myFun () {
<>
</>;
};
let myFun () {
<>
<Namespace.Foo intended=(true) anotherOptional=200 />
<Namespace.Foo intended=(true) anotherOptional=200 />
<Namespace.Foo intended=(true) anotherOptional=200>
<Foo />
<Foo />
<Foo />
<Foo />
<Foo />
<Foo />
<Foo />
</Namespace.Foo>
</>;
};
/**
* Children should wrap without forcing attributes to.
*/
<Foo a=10 b=0>
<Bar />
<Bar />
<Bar />
<Bar />
</Foo>;
/**
* Failing test cases:
*/
/* let res = <Foo a=10 b=(<Foo a=200 />) > */
/* <Bar /> */
/* </Foo>; */
/* let res = <Foo a=10 b=(<Foo a=200 />) />; */
let zzz = Some("oh hai");
/* this should be the only test that generates a warning. We're explicitly testing for this */
let optionalCallSite = <Optional1 required=?zzz />;
fakeRender(optionalCallSite);
let optionalArgument = <Optional2 />;
fakeRender(optionalArgument);
let optionalArgument = <Optional2 optional=?zzz />;
fakeRender(optionalArgument);
let defaultArg = <DefaultArg />;
fakeRender(defaultArg);
let defaultArg = <DefaultArg default=zzz />;
fakeRender(defaultArg);
([@JSX][@bla] NotReallyJSX.createElement([],~foo=1,~bar=2));
([@bla][@JSX] NotReallyJSX.createElement(~foo=1,[],~bar=2));
([@JSX][@bla] notReallyJSX([],~foo=1));
([@bla][@JSX] notReallyJSX(~foo=1,[],~bar=2));
/* children can be at any position */
([@JSX] span(~children=[],~test=true,~foo=2,()));
([@JSX] Optional1.createElement(~children=[],~required=Some("hi"),()));
/* preserve some other attributes too! */
([@JSX][@bla] span(~children=[],~test=true,~foo=2,()));
([@bla][@JSX] span(~children=[],~test=true,~foo=2,()));
([@JSX][@bla] Optional1.createElement(~children=[],~required=Some("hi"),()));
([@bla][@JSX] Optional1.createElement(~children=[],~required=Some("hi"),()));
/* Overeager JSX punning #1099 */
module Metal = {
let fiber = "fiber";
};
module OverEager = {
let createElement(~fiber,~children,()) {displayName: "test"};
};
let element = <OverEager fiber=Metal.fiber />;
type style = {
width: int,
height: int,
paddingTop: int,
paddingLeft: int,
paddingRight: int,
paddingBottom: int
};
module Window = {
let createElement(~style,~children,()) {displayName: "window"};
};
let w =
<Window
style={
width: 10,
height: 10,
paddingTop: 10,
paddingLeft: 10,
paddingRight: 10,
paddingBottom: 10
}
/>;
let foo = None;
let g = <Two ?foo />;
/* https://github.com/facebook/reason/issues/1428 */
<Foo> ...element </Foo>;
<Foo> ...((a) => 1) </Foo>;
<Foo> ...<Foo2 /> </Foo>;
<Foo> ...[|a|] </Foo>;
<Foo> ...(1, 2) </Foo>;
module Foo3 = {
let createElement = (~bar, ~children, ()) => ();
};
<Foo3 bar=<Foo /> />;
let onClickHandler = () => ();
let div = (~onClick, ~children, ()) => ();
<div onClick=onClickHandler> <> "foobar" </> </div>;
/*
* This is identical to just having "foobar" as a single JSX child (which means
* it's in a list).
*/
let yetAnotherDiv = <div onClick=onClickHandler>... <> "foobar" </> </div>;
let tl = [];
/*
* Spreading a list that has an identifier/expression as its tail. This should
* preserve the spread and preserve the braces. [list] is not considered
* simple for the purposes of spreading into JSX, or as a child.
*/
<div onClick=onClickHandler>...{[yetAnotherDiv, ...tl]}</div>;
/*
* This is equivalent to having no children.
*/
<div onClick=onClickHandler>...{[]}</div>;
================================================
FILE: test/4.10/type-jsx.t/run.t
================================================
Format basic
$ refmt --print re ./input.re > ./formatted.re
Print the formatted file
$ cat ./formatted.re
type component = {displayName: string};
module Bar = {
let createElement = (~c=?, ~children, ()) => {
displayName: "test",
};
};
module Nesting = {
let createElement = (~children, ()) => {
displayName: "test",
};
};
module Much = {
let createElement = (~children, ()) => {
displayName: "test",
};
};
module Foo = {
let createElement =
(~a=?, ~b=?, ~children, ()) => {
displayName: "test",
};
};
module One = {
let createElement =
(~test=?, ~foo=?, ~children, ()) => {
displayName: "test",
};
let createElementobvioustypo =
(~test, ~children, ()) => {
displayName: "test",
};
};
module Two = {
let createElement = (~foo=?, ~children, ()) => {
displayName: "test",
};
};
module Sibling = {
let createElement =
(~foo=?, ~children: list(component), ()) => {
displayName: "test",
};
};
module Test = {
let createElement = (~yo=?, ~children, ()) => {
displayName: "test",
};
};
module So = {
let createElement = (~children, ()) => {
displayName: "test",
};
};
module Foo2 = {
let createElement = (~children, ()) => {
displayName: "test",
};
};
module Text = {
let createElement = (~children, ()) => {
displayName: "test",
};
};
module Exp = {
let createElement = (~children, ()) => {
displayName: "test",
};
};
module Pun = {
let createElement =
(~intended=?, ~children, ()) => {
displayName: "test",
};
};
module Namespace = {
module Foo = {
let createElement =
(
~intended=?,
~anotherOptional as x=100,
~children,
(),
) => {
displayName: "test",
};
};
};
module Optional1 = {
let createElement = (~required, ~children, ()) => {
switch (required) {
| Some(a) => { displayName: a }
| None => { displayName: "nope" }
};
};
};
module Optional2 = {
let createElement =
(~optional=?, ~children, ()) => {
switch (optional) {
| Some(a) => { displayName: a }
| None => { displayName: "nope" }
};
};
};
module DefaultArg = {
let createElement =
(~default=Some("foo"), ~children, ()) => {
switch (default) {
| Some(a) => { displayName: a }
| None => { displayName: "nope" }
};
};
};
module LotsOfArguments = {
let createElement =
(
~argument1=?,
~argument2=?,
~argument3=?,
~argument4=?,
~argument5=?,
~argument6=?,
~children,
(),
) => {
displayName: "test",
};
};
let div = (~argument1=?, ~children, ()) => {
displayName: "test",
};
module List1 = {
let createElement = (~children, ()) => {
displayName: "test",
};
};
module List2 = {
let createElement = (~children, ()) => {
displayName: "test",
};
};
module List3 = {
let createElement = (~children, ()) => {
displayName: "test",
};
};
module NotReallyJSX = {
let createElement = (~foo, ~bar, children) => {
displayName: "test",
};
};
let notReallyJSX = (~foo, ~bar, children) => {
displayName: "test",
};
let fakeRender = (el: component) => {
el.displayName;
};
/* end of setup */
let (/><) = (a, b) => a + b;
let (><) = (a, b) => a + b;
let (/>) = (a, b) => a + b;
let (></) = (a, b) => a + b;
let tag1 = 5 />< 6;
let tag2 = 5 >< 7;
let tag3 = 5 /> 7;
let tag4 = 5 ></ 7;
let b = 2;
let selfClosing = <Foo />;
let selfClosing2 = <Foo a=1 b=true />;
let selfClosing3 =
<Foo
a="really long values that should"
b="cause the entire thing to wrap"
/>;
let a = <Foo> <Bar c={a => a + 2} /> </Foo>;
let a3 = <So> <Much> <Nesting /> </Much> </So>;
let a4 =
<Sibling>
<One test=true foo=b />
<Two foo=b />
</Sibling>;
let a5 = <Foo> "testing a string here" </Foo>;
let a6 =
<Foo2>
<Text> "testing a string here" </Text>
<Test yo=1 />
<Text> "another string" </Text>
<Bar />
<Exp> {2 + 4} </Exp>
</Foo2>;
let intended = true;
let punning = <Pun intended />;
let namespace = <Namespace.Foo />;
let c = <Foo />;
let d = <Foo />;
let spaceBefore =
<So> <Much> <Nesting /> </Much> </So>;
let spaceBefore2 = <So> <Much /> </So>;
let siblingNotSpaced =
<So> <Much /> <Much /> </So>;
let jsxInList = [<Foo />];
let jsxInList2 = [<Foo />];
let jsxInListA = [<Foo />];
let jsxInListB = [<Foo />];
let jsxInListC = [<Foo />];
let jsxInListD = [<Foo />];
let jsxInList3 = [<Foo />, <Foo />, <Foo />];
let jsxInList4 = [<Foo />, <Foo />, <Foo />];
let jsxInList5 = [<Foo />, <Foo />];
let jsxInList6 = [<Foo />, <Foo />];
let jsxInList7 = [<Foo />, <Foo />];
let jsxInList8 = [<Foo />, <Foo />];
let testFunc = b => b;
let jsxInFnCall = testFunc(<Foo />);
let lotsOfArguments =
<LotsOfArguments
argument1=1
argument2=2
argument3=3
argument4=4
argument5=5
argument6="test">
<Namespace.Foo />
</LotsOfArguments>;
let lowerCase = <div argument1=1 />;
let b = 0;
let d = 0;
/*
* Should pun the first example:
*/
let a = <Foo a> 5 </Foo>;
let a = <Foo a=b> 5 </Foo>;
let a = <Foo a=b b=d> 5 </Foo>;
let a = <Foo a> 0.55 </Foo>;
let a = <Foo />;
let ident = <Foo> a </Foo>;
let fragment1 = <> <Foo /> <Foo /> </>;
let fragment2 = <> <Foo /> <Foo /> </>;
let fragment3 = <> <Foo /> <Foo /> </>;
let fragment4 = <> <Foo /> <Foo /> </>;
let fragment5 = <> <Foo /> <Foo /> </>;
let fragment6 = <> <Foo /> <Foo /> </>;
let fragment7 = <> <Foo /> <Foo /> </>;
let fragment8 = <> <Foo /> <Foo /> </>;
let fragment9 = <> 2 2 2 2 </>;
let fragment10 = <> 2.2 3.2 4.6 1.2 </>;
let fragment11 = <> "str" </>;
let fragment12 = <> {6 + 2} {6 + 2} {6 + 2} </>;
let fragment13 = <> fragment11 fragment11 </>;
let listOfItems1 = <List1> 1 2 3 4 5 </List1>;
let listOfItems2 =
<List2> 1.0 2.8 3.8 4.0 5.1 </List2>;
let listOfItems3 =
<List3> fragment11 fragment11 </List3>;
/*
* Several sequential simple jsx expressions must be separated with a space.
*/
let thisIsRight = (a, b) => ();
let tagOne = (~children, ()) => ();
let tagTwo = (~children, ()) => ();
/* thisIsWrong <tagOne /><tagTwo />; */
thisIsRight(<tagOne />, <tagTwo />);
/* thisIsWrong <tagOne> </tagOne><tagTwo> </tagTwo>; */
thisIsRight(<tagOne />, <tagTwo />);
let a = (~children, ()) => ();
let b = (~children, ()) => ();
let thisIsOkay =
<List1> <a /> <b /> <a /> <b /> </List1>;
let thisIsAlsoOkay =
<List1> <a /> <b /> </List1>;
/* Doesn't make any sense, but suppose you defined an
infix operator to compare jsx */
<a /> < <b />;
<a /> > <b />;
<a /> < <b />;
<a /> > <b />;
let listOfListOfJsx = [<> </>];
let listOfListOfJsx = [<> <Foo /> </>];
let listOfListOfJsx = [
<> <Foo /> </>,
<> <Bar /> </>,
];
let listOfListOfJsx = [
<> <Foo /> </>,
<> <Bar /> </>,
...listOfListOfJsx,
];
let sameButWithSpaces = [<> </>];
let sameButWithSpaces = [<> <Foo /> </>];
let sameButWithSpaces = [
<> <Foo /> </>,
<> <Bar /> </>,
];
let sameButWithSpaces = [
<> <Foo /> </>,
<> <Bar /> </>,
...sameButWithSpaces,
];
/*
* Test named tag right next to an open bracket.
*/
let listOfJsx = [];
let listOfJsx = [<Foo />];
let listOfJsx = [<Foo />, <Bar />];
let listOfJsx = [
<Foo />,
<Bar />,
...listOfJsx,
];
let sameButWithSpaces = [];
let sameButWithSpaces = [<Foo />];
let sameButWithSpaces = [<Foo />, <Bar />];
let sameButWithSpaces = [
<Foo />,
<Bar />,
...sameButWithSpaces,
];
/**
* Test no conflict with polymorphic variant types.
*/
type thisType = [
| `Foo
| `Bar
];
type t('a) = [< thisType] as 'a;
let asd =
[@foo] <One test=true foo=2> "a" "b" </One>;
let asd2 =
[@foo]
<One.createElementobvioustypo test=false>
"a"
"b"
</One.createElementobvioustypo>;
let span =
(~test: bool, ~foo: int, ~children, ()) => 1;
let asd =
[@foo] <span test=true foo=2> "a" "b" </span>;
/* "video" call doesn't end with a list, so the expression isn't converted to JSX */
let video = (~test: bool, children) => children;
let asd2 = [@foo] [@JSX] video(~test=false, 10);
let div = (~children) => 1;
[@JSX] ((() => div)())(~children=[]);
let myFun = () => {
<>
<Namespace.Foo
intended=true
anotherOptional=200
/>
<Namespace.Foo
intended=true
anotherOptional=200
/>
<Namespace.Foo
intended=true anotherOptional=200>
<Foo />
<Foo />
<Foo />
<Foo />
<Foo />
<Foo />
<Foo />
</Namespace.Foo>
</>;
};
let myFun = () => {
<> </>;
};
let myFun = () => {
<>
<Namespace.Foo
intended=true
anotherOptional=200
/>
<Namespace.Foo
intended=true
anotherOptional=200
/>
<Namespace.Foo
intended=true anotherOptional=200>
<Foo />
<Foo />
<Foo />
<Foo />
<Foo />
<Foo />
<Foo />
</Namespace.Foo>
</>;
};
/**
* Children should wrap without forcing attributes to.
*/
<Foo a=10 b=0>
<Bar />
<Bar />
<Bar />
<Bar />
</Foo>;
/**
* Failing test cases:
*/
/* let res = <Foo a=10 b=(<Foo a=200 />) > */
/* <Bar /> */
/* </Foo>; */
/* let res = <Foo a=10 b=(<Foo a=200 />) />; */
let zzz = Some("oh hai");
/* this should be the only test that generates a warning. We're explicitly testing for this */
let optionalCallSite =
<Optional1 required=?zzz />;
fakeRender(optionalCallSite);
let optionalArgument = <Optional2 />;
fakeRender(optionalArgument);
let optionalArgument =
<Optional2 optional=?zzz />;
fakeRender(optionalArgument);
let defaultArg = <DefaultArg />;
fakeRender(defaultArg);
let defaultArg = <DefaultArg default=zzz />;
fakeRender(defaultArg);
([@bla]
[@JSX]
NotReallyJSX.createElement([], ~foo=1, ~bar=2));
([@bla]
[@JSX]
NotReallyJSX.createElement(~foo=1, [], ~bar=2));
([@bla] [@JSX] notReallyJSX([], ~foo=1));
([@bla] [@JSX] notReallyJSX(~foo=1, [], ~bar=2));
/* children can be at any position */
<span test=true foo=2 />;
<Optional1 required={Some("hi")} />;
/* preserve some other attributes too! */
([@bla] <span test=true foo=2 />);
([@bla] <span test=true foo=2 />);
([@bla] <Optional1 required={Some("hi")} />);
([@bla] <Optional1 required={Some("hi")} />);
/* Overeager JSX punning #1099 */
module Metal = {
let fiber = "fiber";
};
module OverEager = {
let createElement = (~fiber, ~children, ()) => {
displayName: "test",
};
};
let element = <OverEager fiber=Metal.fiber />;
type style = {
width: int,
height: int,
paddingTop: int,
paddingLeft: int,
paddingRight: int,
paddingBottom: int,
};
module Window = {
let createElement = (~style, ~children, ()) => {
displayName: "window",
};
};
let w =
<Window
style={
width: 10,
height: 10,
paddingTop: 10,
paddingLeft: 10,
paddingRight: 10,
paddingBottom: 10,
}
/>;
let foo = None;
let g = <Two ?foo />;
/* https://github.com/facebook/reason/issues/1428 */
<Foo> ...element </Foo>;
<Foo> ...{a => 1} </Foo>;
<Foo> ...<Foo2 /> </Foo>;
<Foo> ...[|a|] </Foo>;
<Foo> ...(1, 2) </Foo>;
module Foo3 = {
let createElement = (~bar, ~children, ()) =>
();
};
<Foo3 bar={<Foo />} />;
let onClickHandler = () => ();
let div = (~onClick, ~children, ()) => ();
<div onClick=onClickHandler>
<> "foobar" </>
</div>;
/*
* This is identical to just having "foobar" as a single JSX child (which means
* it's in a list).
*/
let yetAnotherDiv =
<div onClick=onClickHandler> "foobar" </div>;
let tl = [];
/*
* Spreading a list that has an identifier/expression as its tail. This should
* preserve the spread and preserve the braces. [list] is not considered
* simple for the purposes of spreading into JSX, or as a child.
*/
<div onClick=onClickHandler>
...{[yetAnotherDiv, ...tl]}
</div>;
/*
* This is equivalent to having no children.
*/
<div onClick=onClickHandler />;
Type-check basics
$ ocamlc -c -pp 'refmt --print binary' -intf-suffix .rei -impl formatted.re
File "formatted.re", line 463, characters 23-26:
463 | <Optional1 required=?zzz />;
^^^
Warning 43: the label required is not optional.
Format the formatted file back
$ refmt --print re ./formatted.re > ./formatted_back.re
Ensure idempotency: first format and second format are the same
$ diff formatted.re formatted_back.re
================================================
FILE: test/4.10/typecheck-let-ops.t
================================================
$ cat > input.ml <<EOF
> open struct
> type t = string
> end
>
> let (let+) x f = List.map f x
>
> let (and+) = List.map2 (fun x y -> x,y)
>
> let x =
> let+ x = [2]
> and+ y = [3]
> in
> x, y
>
> let y =
> let+ x = [2] in
> x
> EOF
Format basic
$ refmt --print re ./input.ml > ./formatted.re
Type-check basics
$ ocamlc -c -pp 'refmt --print binary' -intf-suffix .rei -impl formatted.re
Format the formatted file back
$ refmt --print re ./formatted.re > ./formatted_back.re
Ensure idempotency: first format and second format are the same
$ diff formatted.re formatted_back.re
================================================
FILE: test/4.12/attributes-re.t/input.re
================================================
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
/**
* Generally, dangling attributes [@..] apply to everything to the left of it,
* up until a comma, equals asignment, arrow, bar, or infix symbol (+/-) or
* prefix.
*
* This has a nice side effect when printing the terms:
* If a node has attributes attached to it,
*/
[@ocaml.text "Floating comment text should be removed"];
/**
* Core language features:
* ----------------------
*/
[@ocaml.doc "Floating doc text should be removed"];
[@itemAttributeOnTypeDef] [@ocaml.text "removed text on type def"]
type itemText = int;
type nodeText = [@ocaml.text "removed text on item"] int;
[@itemAttributeOnTypeDef]
[@ocaml.text "removed text on type def"]
type nodeAndItemText =
[@ocaml.text "removed text on item"] int;
[@itemAttributeOnTypeDef] [@ocaml.doc "removed doc on type def"]
type itemDoc = int;
[@itemAttributeOnTypeDef]
type nodeDoc = [@ocaml.text "removed text on item"] int;
[@itemAttributeOnTypeDef] [@ocaml.doc "removed doc on type def"]
type nodeAndItemDoc =
[@ocaml.text "removed text on item"] int;
[@itemAttributeOnTypeDef]
type x = int;
type attributedInt = [@onTopLevelTypeDef] int;
[@itemAttributeOnTypeDef]
type attributedIntsInTuple = ([@onInt] int, [@onFloat] float);
type myDataType('x,'y) = | MyDataType('x,'y);
type myType =
[@onEntireType]
myDataType ([@onOptionInt] option(int),
[@onOption] option(float));
let thisInst : myType =
[@attOnEntireDatatype] MyDataType(Some(10),Some(10.0));
let thisInst : myType =
[@attOnEntireDatatype] MyDataType([@onFirstParam] Some(10), Some(10.0));
let x = ([@onHello] "hello");
let x = [@onHello] "hello";
let x = "hello" ++ ([@onGoodbye] "goodbye");
let x = ([@onHello] "hello") ++ "goodbye";
let x = [@onHello] "hello" ++ "goodbye";
let x = "hello" ++ [@onGoodbye] "goodbye";
let x = [@onEverything] ("hello" ++ "goodbye");
let x = 10 + ([@on20] 20);
let x = 10 + [@on20] 20;
let x = [@on10] 10 + 20;
let x = ([@on10] 10) + 20;
let x = [@attrEverything] (10 + 20);
let x = 10 - ([@on20] 20);
let x = 10 - [@on20] 20;
let x = [@on10] 10 - 20;
let x = ([@on10] 10) - 20;
let x = [@attrEntireEverything] (10 - 20);
let x = true && ([@onFalse] false);
let x = true && [@onFalse] false;
let x = [@onTrue] true && false;
let x = ([@onTrue] true) && false;
let x = [@attrEverything] (true && false);
/* now make sure to try with variants (tagged and `) */
/**
* How attribute parsings respond to other syntactic constructs.
*/
let add(a) { [@onRet] a };
let add = fun(a) => [@onRet] a;
let add = [@onEntireFunction] (fun(a) => a);
let res = if (true) false else [@onFalse] false;
let res = [@onEntireIf] (if (true) false else false);
let add(a,b) = [@onEverything] ([@onA] a + b);
let add(a,b) = [@onEverything] ([@onA]a + ([@onB]b));
let add = (a,b) => a + [@onB]b;
let both = [@onEntireFunction](fun(a) => a);
let both(a,b) = [@onEverything]([@onA]a && b);
let both(a,b) = [@onA] a && [@onB] ([@onB] b);
let both = fun(a,b) => [@onEverything](a && b);
let thisVal = 10;
let x = 20 + - [@onFunctionCall] add(thisVal,thisVal);
let x = [@onEverything] (20 + - add(thisVal,thisVal));
let x = - [@onFunctionCall] add(thisVal,thisVal);
let x = [@onEverything] (- add(thisVal,thisVal));
let bothTrue(x,y) = {contents: x && y};
let something = [@onEverythingToRightOfEquals](bothTrue(true,true)^);
let something = ([@onlyOnArgumentToBang]bothTrue(true,true))^;
let res = [@appliesToEntireFunctionApplication] add(2,4);
[@appliesToEntireFunctionApplication]add(2,4);
let myObj = {
pub p () = {
pub z () = 10
};
};
let result = [@onSecondSend]([@attOnFirstSend]myObj#p ())#z ();
[@onRecordFunctions]
type recordFunctions = {
p: (unit) => ([@onUnit] recordFunctions),
q: [@onArrow] ((unit) => unit)
}
[@onUnusedType]
and unusedType = unit;
[@onMyRecord]
let rec myRecord = {
p: fun () => myRecord,
q: fun () => ()
}
[@onUnused]
and unused = ();
let result = [@onSecondSend]([@attOnFirstSend]myRecord.p()).q();
[@onVariantType]
type variantType =
[@onInt] | Foo(int)
| Bar ([@onInt] int)
| Baz;
[@onVariantType]
type gadtType('x) =
| Foo(int) : [@onFirstRow] gadtType(int)
| Bar ([@onInt]int) : [@onSecondRow]gadtType(unit)
| Baz: [@onThirdRow] gadtType ([@onUnit] unit);
[@floatingTopLevelStructureItem hello];
[@itemAttributeOnEval]
print_string("hello");
[@itemAttrOnFirst]
let firstBinding = "first"
[@itemAttrOnSecond]
and secondBinding = "second";
/**
* Let bindings.
* ----------------------
*/
let showLets () = [@onOuterLet] {
let tmp = 20;
[@onFinalLet] {
let tmpTmp = tmp + tmp;
tmpTmp + tmpTmp;
}
};
/**
* Classes:
* ------------
*/
/**
* In curried sugar, the class_expr attribute will apply to the return.
*/
[@moduleItemAttribute]
class boxA('a) (init: 'a) = [@onReturnClassExpr] {
[@ocaml.text "Floating comment text should be removed"];
[@ocaml.doc "Floating comment text should be removed"];
pub pr = init + init + init;
};
/**
* In non-curried sugar, the class_expr still sticks to "the simple thing".
*/
class boxB('a) =
fun (init: 'a) => [@stillOnTheReturnBecauseItsSimple] {
pub pr = init + init + init;
};
/* To be able to put an attribute on just the return in that case, use
* parens. */
[@onBoxC x ; y]
class boxC('a) = [@onEntireFunction] (
fun (init: 'a) => (
[@onReturnClassExpr] {
pub pr = init + init + init;
}
)
);
[@moduleItemAttribute onTheTupleClassItem;]
class tupleClass('a,'b)(init: ('a, 'b)) {
let one = [@exprAttr ten;] 10;
let two = [@exprAttr twenty;] 20
and three = [@exprAttr thirty;] 30;
[@pr prMember;]
pub pr = one + two + three;
};
[@structureItem]
class type addablePointClassType = {
[@ocaml.text "Floating comment text should be removed"];
[@ocaml.doc "Floating comment text should be removed"];
pub x: int;
pub y: int;
pub add: (addablePointClassType, addablePointClassType) => int;
}
[@structureItem]
and anotherClassType = {
pub foo: int;
pub bar: int;
};
class type _x = [@bs]{ pub height : int };
class type _y { [@bs.set] pub height : int };
[@attr] class type _z { pub height : int };
module NestedModule {
[@floatingNestedStructureItem hello];
};
[@structureItem]
module type HasAttrs = {
[@onTypeDef]
type t = int;
[@floatingNestedSigItem hello];
[@sigItem]
class type foo = {pub foo: int; pub bar: int;};
[@sigItem]
class fooBar: (int) => foo;
[@ocaml.text "Floating comment text should be removed"];
[@ocaml.doc "Floating comment text should be removed"];
};
type s = S(string);
let S ([@onStr] str) = S ([@onHello]"hello");
let [@onConstruction](S(str)) = [@onConstruction](S("hello"));
type xy = | X(string)
| Y(string);
let myFun = fun ([@onConstruction]X(hello) | [@onConstruction]Y(hello)) => hello;
let myFun = fun (X ([@onHello] hello ) | Y ([@onHello]hello )) => hello;
/* Another bug: Cannot have an attribute on or pattern
let myFun = fun ((X(hello) | Y(hello)) [@onOrPattern]) => hello;
*/
/* Melange FFI item attributes */
[@bs.val]
external imul : (int, int) => int = "Math.imul";
let module Js {
type t('a);
};
type classAttributesOnKeys = {
.
[@bs.set] key1 : string,
/* The follow two are the same */
[@bs.get {null}] key2 : [@onType2] Js.t(int),
[@bs.get {null}] key3 : ([@onType2] (Js.t(int))),
key4 : Js.t ([@justOnInt] int)
};
/* extensible variants */
type attr = ..;
[@block]
type attr +=
[@tag1] [@tag2] | Str
[@tag3] | Float ;
type reconciler('props) = ..;
[@onVariantType]
type reconciler('props) +=
| Foo(int) : [@onFirstRow] reconciler(int)
| Bar ([@onInt] int) : [@onSecondRow] reconciler(unit)
[@baz] | Baz: [@onThirdRow] reconciler ([@onUnit] unit);
type water = ..;
type water += pri [@foo] | [@foo2] MineralWater | SpringWater;
type cloud = string;
type water += pri | [@h2o] PreparedWater | [@nature] RainWater(cloud) | [@toxic] MeltedSnowWaterFromNuclearWastelandWithALineBreakBecauseTheNameIsSoLong;
/* reasonreact */
type element;
type reactElement;
type reactClass;
/* "react-dom" shouldn't spread the attribute over multiple lines */
[@bs.val] [@bs.module "react-dom"]
external render : (reactElement, element) => unit = "render";
[@bs.module "f"]
external f : (int) => int = "f";
[@bs.val] [@bs.module "react"] [@bs.splice]
external createCompositeElementInternalHack
: (reactClass, Js.t({.. reasonProps : 'props}), array(reactElement)) => reactElement
= "createElement";
external add_nat: (int, int) => int = "add_nat_bytecode" "add_nat_native";
[@bs.module "Bar"] [@ocaml.deprecated "Use bar instead. It's a much cooler function. This string needs to be a little long"]
external foo : (bool) => bool = "";
/* Attributes on an entire polymorphic variant leaf */
[@bs.module "fs"]
external readFileSync : (
~name: string,
[@bs.string] [
| `utf8
[@bs.as "ascii"] | `my_name
]
) => string = "";
[@bs.module "fs"]
external readFileSync2 : (
~name: string,
[@bs.string] [
[@bs.as "ascii"] | `utf8
[@bs.as "ascii"] | `my_name
]) => string = "";
/* Ensure that attributes on extensions are printed */
[@test
[@attr]
[%%extension]
];
external debounce : (int, [@bs.meth] unit) => unit;
external debounce : (int, [@bs.meth] unit) => unit = "debounce";
external debounce : (int, [@bs.meth] unit) => unit = "";
external debounce : int => ([@bs.meth] (unit => unit)) = "";
external debounce : int => ([@bs.meth] (unit => unit)) => ([@bs.meth] (unit => unit)) = "";
external debounce : int => ([@bs.meth] (unit => unit)) => ([@bs.meth] (unit => unit)) => ([@bs.meth] (unit => unit)) = "";
external debounce : int => ([@bs.meth] (unit => unit)) => ([@bs.meth] (unit => [@bs.meth] (unit => unit))) => ([@bs.meth] (unit => unit)) = "";
let x = "hi";
let res = switch (x) {
| _ =>
[@attr]
{
open String;
open Array;
concat;
index_from;
}
};
let res = switch (x) {
| _ =>
[@attr]
{
open String;
open Array;
concat;
}
};
/* GADT */
type value =
| [@foo] VBool'(bool): [@bar] value
| VInt'(int): value;
/** Different payloads **/
/* Empty structure */
[@haha]
let x = 5;
/* Expression structure */
[@haha "hello world"]
let x = 5;
/* structure_item */
[@haha let x = 5]
let x = 5;
/* structure */
[@haha let x = 5; module X = {};]
let x = 5;
/* Pattern */
[@haha? Some(_) ]
let x = 5;
/* Type */
[@haha: option(int)]
let x = 5;
/* Record item attributes */
type t_ = {
/** Comment attribute on record item */
x: int
};
type tt = {
[@attr "on record field"]
x: int
};
type ttt = {
[@attr "on record field"]
x: [@attr "on type itself"] int
};
type tttt = {
/** Comment attribute on record item */
x: int,
[@regularAttribute "on next item"]
y: int
};
type ttttt = [@attr "moved to first row"] {
[@attr]
x: int
};
type tttttt = {
[@attr "testing with mutable field"]
mutable x: int
};
let tmp = {
/** On if statement */
if (true) {
true
} else {
false
};
};
type foo =
option(
[@foo ["how does this break", "when long enough"]] (
[@bar] (int => int),
[@baz] (int => int),
),
);
module Callbacks = {
let cb = () => 1 + 1;
};
let test = {
let _x = 1;
[@attr1]
open Callbacks;
let _s = "hello" ++ "!";
[@attr2] Callbacks.("hello" ++ "!");
};
[@test.call string => string]
let processCommandItem = 12;
module type Foo = { [@someattr] let foo: int => int;};
[@bs.deriving abstract]
type t = {
/** Position (in the pre-change coordinate system) where the change ended. */
[@bs.as "to"] [@bar]
to_: string,
};
[@bs.deriving abstract]
type editorConfiguration = {
[@bs.optional]
/** Determines whether horizontal cursor movement through right-to-left (Arabic, Hebrew) text
is visual (pressing the left arrow moves the cursor left)
or logical (pressing the left arrow moves to the next lower index in the string, which is visually right in right-to-left text).
The default is false on Windows, and true on other platforms. */
rtlMoveVisually: bool,
};
module Fmt = {
let barBaz = () => ();
type record = {x: int};
};
Fmt.([@foo] barBaz());
Fmt.([@foo] {x: 1});
Fmt.([@foo] [1, 2, 3]);
Fmt.([@foo] (1, 2, 3));
Fmt.([@foo] {val x = 10});
/**
* Attributes are associate with the identifier, function call, constructor
* appcation or constructor application pattern in front of it - up until a
* type constraint, an | (or) or an 'as'.
*/
let punnned_lbl_a = (~lbl as [@ATTR] lbl) => lbl;
let punnned_lbl_b = (~lbl as [@ATTR] (lbl: int)) => lbl;
let punnned_lbl_c = (~lbl as [@ATTR] ([@ATTR2] lbl)) => lbl;
let punnned_lbl_d = (~lbl as [@ATTR] ([@ATTR2] lbl: int)) => lbl;
let punnned_lbl_e = (~lbl as [@ATTR] ([@ATTR2] (lbl: int))) => lbl;
let punnned_lbl_f = (~lbl as [@ATTR] lbl: int) => lbl;
let punnned_lbl_g = (~lbl as ([@ATTR] lbl: int)) => lbl;
let punnned_lbl_h = (~lbl as ([@ATTR] (lbl: int))) => lbl;
/** Attributes have lower precedence than type constraint. The following should
* be printed identically. */
let punnned_lbl_i = (~lbl as [@ATTR] lbl: int) => lbl;
let punnned_lbl_i' = (~lbl as [@ATTR] (lbl: int)) => lbl;
let nonpunned_lbla = (~lbl as [@ATTR] lblNonpunned) => lblNonpunned;
let nonpunned_lbl_b = (~lbl as [@ATTR] (lblNonpunned: int)) => lblNonpunned;
let nonpunned_lbl_c = (~lbl as [@ATTR] ([@ATTR2] lblNonpunned)) => lblNonpunned;
let nonpunned_lbl_d = (~lbl as [@ATTR] ([@ATTR2] lblNonpunned: int)) => lblNonpunned;
let nonpunned_lbl_e = (~lbl as [@ATTR] ([@ATTR2] (lblNonpunned: int))) => lblNonpunned;
let nonpunned_lbl_f = (~lbl as [@ATTR] lblNonpunned: int) => lblNonpunned;
let nonpunned_lbl_g = (~lbl as ([@ATTR] lblNonpunned: int)) => lblNonpunned;
let nonpunned_lbl_h = (~lbl as ([@ATTR] (lblNonpunned: int))) => lblNonpunned;
let nonpunned_lbl_i = (~lbl as [@ATTR] lblNonpunned: int) => lblNonpunned;
let nonpunned_lbl_i' = (~lbl as [@ATTR] (lblNonpunned: int)) => lblNonpunned;
let defaulted_punnned_lbl_a = (~lbl as [@ATTR] lbl=0, ()) => lbl;
let defaulted_punnned_lbl_b = (~lbl as [@ATTR] (lbl: int)=0, ()) => lbl;
let defaulted_punnned_lbl_c = (~lbl as [@ATTR] ([@ATTR2] lbl)=0, ()) => lbl;
let defaulted_punnned_lbl_d = (~lbl as [@ATTR] ([@ATTR2] lbl: int)=0, ()) => lbl;
let defaulted_punnned_lbl_e = (~lbl as [@ATTR] ([@ATTR2] (lbl: int))=0, ()) => lbl;
let defaulted_punnned_lbl_f = (~lbl as [@ATTR] lbl: int=0, ()) => lbl;
let defaulted_punnned_lbl_g = (~lbl as ([@ATTR] lbl: int)=0, ()) => lbl;
let defaulted_punnned_lbl_h = (~lbl as ([@ATTR] (lbl: int))=0, ()) => lbl;
/** Attributes have lower precedence than type constraint. The following should
* be printed identically. */
let defaulted_punnned_lbl_i = (~lbl as [@ATTR] lbl: int=0, ()) => lbl;
let defaulted_punnned_lbl_i' = (~lbl as [@ATTR] (lbl: int)=0, ()) => lbl;
let defaulted_nonpunned_lbla = (~lbl as [@ATTR] lblNonpunned=0, ()) => lblNonpunned;
let defaulted_nonpunned_lbl_b = (~lbl as [@ATTR] (lblNonpunned: int)=0, ()) => lblNonpunned;
let defaulted_nonpunned_lbl_c = (~lbl as [@ATTR] ([@ATTR2] lblNonpunned)=0, ()) => lblNonpunned;
let defaulted_nonpunned_lbl_d = (~lbl as [@ATTR] ([@ATTR2] lblNonpunned: int)=0, ()) => lblNonpunned;
let defaulted_nonpunned_lbl_e = (~lbl as [@ATTR] ([@ATTR2] (lblNonpunned: int))=0, ()) => lblNonpunned;
let defaulted_nonpunned_lbl_f = (~lbl as [@ATTR] lblNonpunned: int=0, ()) => lblNonpunned;
let defaulted_nonpunned_lbl_g = (~lbl as ([@ATTR] lblNonpunned: int)=0, ()) => lblNonpunned;
let defaulted_nonpunned_lbl_h = (~lbl as ([@ATTR] (lblNonpunned: int))=0, ()) => lblNonpunned;
let defaulted_nonpunned_lbl_i = (~lbl as [@ATTR] lblNonpunned: int=0, ()) => lblNonpunned;
let defaulted_nonpunned_lbl_i' = (~lbl as [@ATTR] (lblNonpunned: int)=0, ()) => lblNonpunned;
/* Won't parse: let [@attr] x1 : int = xInt; */
let xInt = 0;
/**
Attribute on the pattern node inside of constraint
pattern (
Ppat_constraint(
pattern(@xxx, Ppat_var "x"),
coretype
)
)
This will get sugared to `let ([@attr] x2) : int = xInt`
*/
let ([@attr] x2 : int) = xInt;
/**
Attribute on the pattern holding the constraint:
pattern(
@xxx
Ppat_constraint(
pattern(Pexpident "x"),
coretype
)
)
*/
let ([@attr] (x3 : int)) = xInt;
let ([@attr] ([@attr0] x4: int)) = xInt;
let ([@attr] (([@attr0] x5): int)) = xInt;
type eitherOr('a, 'b) = Either('a) | Or('b);
let [@attr] Either(a) | Or(a) = Either("hi");
// Can drop the the parens around Either.
let ([@attr] Either(a)) | Or(a) = Either("hi");
// Can drop the parens around Or.
let Either(b) | ([@attr] Or(b)) = Either("hi");
// Should keep the parens around both
let [@attr] (Either(a) | Or(a)) = Either("hi");
// Should keep the parens
let [@attr] (_x as xAlias) = 10;
// Should drop the parens
let ([@attr] _x) as xAlias' = 10;
/**
Attribute on the expression node inside of constraint
expression(
Pexp_constraint(
expression(@xxx, Pexpident "x"),
coretype
)
)
*/
let _ = ([@xxx] xInt : int); // This should format the same
let _ = (([@xxx] xInt) : int); // This should format the same
/**
Attribute on the expression holding the constraint:
expression(
@xxx
Pexp_constraint(
expression(Pexpident "x"),
coretype
)
)
*/
let _ = [@xxx] (xInt : int); // This should format the same
[@foo? [@attr] (x: int)];
[@foo? [@attr] ([@bar] x: int)];
[@foo ? [@attr] (Either("hi") | Or("hi"))];
================================================
FILE: test/4.12/attributes-re.t/run.t
================================================
Format basic
$ refmt --print re ./input.re > ./formatted.re
Print the formatted file
$ cat ./formatted.re
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
/**
* Generally, dangling attributes [@..] apply to everything to the left of it,
* up until a comma, equals asignment, arrow, bar, or infix symbol (+/-) or
* prefix.
*
* This has a nice side effect when printing the terms:
* If a node has attributes attached to it,
*/;
/**Floating comment text should be removed*/;
/**
* Core language features:
* ----------------------
*/;
/**Floating doc text should be removed*/;
/**removed text on type def*/
[@itemAttributeOnTypeDef]
type itemText = int;
type nodeText =
/**removed text on item*/ int;
/**removed text on type def*/
[@itemAttributeOnTypeDef]
type nodeAndItemText =
/**removed text on item*/ int;
/**removed doc on type def*/
[@itemAttributeOnTypeDef]
type itemDoc = int;
[@itemAttributeOnTypeDef]
type nodeDoc =
/**removed text on item*/ int;
/**removed doc on type def*/
[@itemAttributeOnTypeDef]
type nodeAndItemDoc =
/**removed text on item*/ int;
[@itemAttributeOnTypeDef]
type x = int;
type attributedInt = [@onTopLevelTypeDef] int;
[@itemAttributeOnTypeDef]
type attributedIntsInTuple = (
[@onInt] int,
[@onFloat] float,
);
type myDataType('x, 'y) =
| MyDataType('x, 'y);
type myType =
[@onEntireType]
myDataType(
[@onOptionInt] option(int),
[@onOption] option(float),
);
let thisInst: myType =
[@attOnEntireDatatype]
MyDataType(Some(10), Some(10.0));
let thisInst: myType =
[@attOnEntireDatatype]
MyDataType(
[@onFirstParam] Some(10),
Some(10.0),
);
let x = [@onHello] "hello";
let x = [@onHello] "hello";
let x = "hello" ++ [@onGoodbye] "goodbye";
let x = [@onHello] "hello" ++ "goodbye";
let x = [@onHello] "hello" ++ "goodbye";
let x = "hello" ++ [@onGoodbye] "goodbye";
let x = [@onEverything] ("hello" ++ "goodbye");
let x = 10 + [@on20] 20;
let x = 10 + [@on20] 20;
let x = [@on10] 10 + 20;
let x = [@on10] 10 + 20;
let x = [@attrEverything] (10 + 20);
let x = 10 - [@on20] 20;
let x = 10 - [@on20] 20;
let x = [@on10] 10 - 20;
let x = [@on10] 10 - 20;
let x = [@attrEntireEverything] (10 - 20);
let x = true && [@onFalse] false;
let x = true && [@onFalse] false;
let x = [@onTrue] true && false;
let x = [@onTrue] true && false;
let x = [@attrEverything] (true && false);
/* now make sure to try with variants (tagged and `) */
/**
* How attribute parsings respond to other syntactic constructs.
*/
let add = a =>
[@onRet]
{
a;
};
let add = a => [@onRet] a;
let add = [@onEntireFunction] (a => a);
let res =
if (true) {false} else {[@onFalse] false};
let res =
[@onEntireIf] (if (true) {false} else {false});
let add = (a, b) =>
[@onEverything] ([@onA] a + b);
let add = (a, b) =>
[@onEverything] ([@onA] a + [@onB] b);
let add = (a, b) => a + [@onB] b;
let both = [@onEntireFunction] (a => a);
let both = (a, b) =>
[@onEverything] ([@onA] a && b);
let both = (a, b) =>
[@onA] a && [@onB] [@onB] b;
let both = (a, b) => [@onEverything] (a && b);
let thisVal = 10;
let x =
20
+ (- [@onFunctionCall] add(thisVal, thisVal));
let x =
[@onEverything]
(20 + (- add(thisVal, thisVal)));
let x =
- [@onFunctionCall] add(thisVal, thisVal);
let x =
[@onEverything] (- add(thisVal, thisVal));
let bothTrue = (x, y) => { contents: x && y };
let something =
[@onEverythingToRightOfEquals]
(bothTrue(true, true))^;
let something =
([@onlyOnArgumentToBang] bothTrue(true, true))
^;
let res =
[@appliesToEntireFunctionApplication]
add(2, 4);
[@appliesToEntireFunctionApplication]
add(2, 4);
let myObj = {
pub p = () => { pub z = () => 10 }
};
let result =
[@onSecondSend]
([@attOnFirstSend] myObj#p())#z();
[@onRecordFunctions]
type recordFunctions = {
p: unit => [@onUnit] recordFunctions,
q: [@onArrow] (unit => unit),
}
[@onUnusedType]
and unusedType = unit;
[@onMyRecord]
let rec myRecord = {
p: () => myRecord,
q: () => (),
}
[@onUnused]
and unused = ();
let result =
[@onSecondSend]
([@attOnFirstSend] myRecord.p()).q();
[@onVariantType]
type variantType =
| [@onInt] Foo(int)
| Bar([@onInt] int)
| Baz;
[@onVariantType]
type gadtType('x) =
| Foo(int): [@onFirstRow] gadtType(int)
| Bar([@onInt] int)
: [@onSecondRow] gadtType(unit)
| Baz: [@onThirdRow] gadtType([@onUnit] unit);
[@floatingTopLevelStructureItem hello];
[@itemAttributeOnEval]
print_string("hello");
[@itemAttrOnFirst]
let firstBinding = "first"
[@itemAttrOnSecond]
and secondBinding = "second";
/**
* Let bindings.
* ----------------------
*/
let showLets = () =>
[@onOuterLet]
{
let tmp = 20;
[@onFinalLet]
{
let tmpTmp = tmp + tmp;
tmpTmp + tmpTmp;
};
};
/**
* Classes:
* ------------
*/
/**
* In curried sugar, the class_expr attribute will apply to the return.
*/
[@moduleItemAttribute]
class boxA ('a) (init: 'a) =
[@onReturnClassExpr] {
/**Floating comment text should be removed*/;
/**Floating comment text should be removed*/;
pub pr = init + init + init;
};
/**
* In non-curried sugar, the class_expr still sticks to "the simple thing".
*/
class boxB ('a) (init: 'a) =
[@stillOnTheReturnBecauseItsSimple] {
pub pr = init + init + init;
};
/* To be able to put an attribute on just the return in that case, use
* parens. */
[@onBoxC
x;
y
]
class boxC ('a) =
[@onEntireFunction] (
fun (init: 'a) =>
[@onReturnClassExpr] {
pub pr = init + init + init;
}
);
[@moduleItemAttribute onTheTupleClassItem]
class tupleClass ('a, 'b) (init: ('a, 'b)) = {
let one = [@exprAttr ten] 10;
let two = [@exprAttr twenty] 20
and three = [@exprAttr thirty] 30;
[@pr prMember] pub pr = one + two + three;
};
[@structureItem]
class type addablePointClassType = {
/**Floating comment text should be removed*/;
/**Floating comment text should be removed*/;
pub x: int;
pub y: int;
pub add:
(
addablePointClassType,
addablePointClassType
) =>
int;
}
[@structureItem]
and anotherClassType = {
pub foo: int;
pub bar: int;
};
class type _x =
[@bs]
{
pub height: int;
};
class type _y = {
[@bs.set]
pub height: int;
};
[@attr]
class type _z = {
pub height: int;
};
module NestedModule = {
[@floatingNestedStructureItem hello];
};
[@structureItem]
module type HasAttrs = {
[@onTypeDef]
type t = int;
[@floatingNestedSigItem hello];
[@sigItem]
class type foo = {
pub foo: int;
pub bar: int;
};
[@sigItem]
class fooBar: (int) => foo;
/**Floating comment text should be removed*/;
/**Floating comment text should be removed*/;
};
type s =
| S(string);
let S([@onStr] str) = S([@onHello] "hello");
let [@onConstruction] S(str) =
[@onConstruction] S("hello");
type xy =
| X(string)
| Y(string);
let myFun =
(
[@onConstruction] X(hello) |
[@onConstruction] Y(hello),
) => hello;
let myFun =
(
X([@onHello] hello) | Y([@onHello] hello),
) => hello;
/* Another bug: Cannot have an attribute on or pattern
let myFun = fun ((X(hello) | Y(hello)) [@onOrPattern]) => hello;
*/
/* Melange FFI item attributes */
[@bs.val]
external imul: (int, int) => int = "Math.imul";
module Js = {
type t('a);
};
type classAttributesOnKeys = {
.
[@bs.set] key1: string,
/* The follow two are the same */
[@bs.get
{
null;
}
]
key2: [@onType2] Js.t(int),
[@bs.get
{
null;
}
]
key3: [@onType2] Js.t(int),
key4: Js.t([@justOnInt] int),
};
/* extensible variants */
type attr = ..;
[@block]
type attr +=
| [@tag1] [@tag2] Str
| [@tag3] Float;
type reconciler('props) = ..;
[@onVariantType]
type reconciler('props) +=
| Foo(int): [@onFirstRow] reconciler(int)
| Bar([@onInt] int): [@onSecondRow]
reconciler(unit)
| [@baz]
Baz: [@onThirdRow]
reconciler([@onUnit] unit);
type water = ..;
type water +=
pri
| [@foo] [@foo2] MineralWater
| SpringWater;
type cloud = string;
type water +=
pri
| [@h2o] PreparedWater
| [@nature] RainWater(cloud)
| [@toxic]
MeltedSnowWaterFromNuclearWastelandWithALineBreakBecauseTheNameIsSoLong;
/* reasonreact */
type element;
type reactElement;
type reactClass;
/* "react-dom" shouldn't spread the attribute over multiple lines */
[@bs.val] [@bs.module "react-dom"]
external render: (reactElement, element) => unit =
"render";
[@bs.module "f"] external f: int => int = "f";
[@bs.val] [@bs.module "react"] [@bs.splice]
external createCompositeElementInternalHack:
(
reactClass,
{.. "reasonProps": 'props },
array(reactElement)
) =>
reactElement =
"createElement";
external add_nat: (int, int) => int =
"add_nat_bytecode" "add_nat_native";
[@bs.module "Bar"]
[@ocaml.deprecated
"Use bar instead. It's a much cooler function. This string needs to be a little long"
]
external foo: bool => bool;
/* Attributes on an entire polymorphic variant leaf */
[@bs.module "fs"]
external readFileSync:
(
~name: string,
[@bs.string] [
| `utf8
| [@bs.as "ascii"] `my_name
]
) =>
string;
[@bs.module "fs"]
external readFileSync2:
(
~name: string,
[@bs.string] [
| [@bs.as "ascii"] `utf8
| [@bs.as "ascii"] `my_name
]
) =>
string;
/* Ensure that attributes on extensions are printed */
[@test [@attr] [%%extension]];
external debounce:
(int, [@bs.meth] unit) => unit;
external debounce: (int, [@bs.meth] unit) => unit =
"debounce";
external debounce:
(int, [@bs.meth] unit) => unit;
external debounce:
int => [@bs.meth] (unit => unit);
external debounce:
(int, [@bs.meth] (unit => unit)) =>
[@bs.meth] (unit => unit);
external debounce:
(
int,
[@bs.meth] (unit => unit),
[@bs.meth] (unit => unit)
) =>
[@bs.meth] (unit => unit);
external debounce:
(
int,
[@bs.meth] (unit => unit),
[@bs.meth] (
unit => [@bs.meth] (unit => unit)
)
) =>
[@bs.meth] (unit => unit);
let x = "hi";
let res =
switch (x) {
| _ =>
[@attr]
open String;
open Array;
concat;
index_from;
};
let res =
switch (x) {
| _ => [@attr] String.(Array.(concat))
};
/* GADT */
type value =
| [@foo] VBool'(bool): [@bar] value
| VInt'(int): value;
/** Different payloads **/
/* Empty structure */
[@haha]
let x = 5;
/* Expression structure */
[@haha "hello world"]
let x = 5;
/* structure_item */
[@haha let x = 5]
let x = 5;
/* structure */
[@haha
let x = 5;
module X = {}
]
let x = 5;
/* Pattern */
[@haha? Some(_)]
let x = 5;
/* Type */
[@haha: option(int)]
let x = 5;
/* Record item attributes */
type t_ = {
/** Comment attribute on record item */
x: int,
};
type tt = {
[@attr "on record field"]
x: int,
};
type ttt = {
[@attr "on record field"]
x: [@attr "on type itself"] int,
};
type tttt = {
/** Comment attribute on record item */
x: int,
[@regularAttribute "on next item"]
y: int,
};
type ttttt = {
[@attr "moved to first row"] [@attr]
x: int,
};
type tttttt = {
[@attr "testing with mutable field"]
mutable x: int,
};
let tmp =
/** On if statement */
(if (true) {true} else {false});
type foo =
option(
[@foo
[
"how does this break",
"when long enough",
]
] (
[@bar] (int => int),
[@baz] (int => int),
),
);
module Callbacks = {
let cb = () => 1 + 1;
};
let test = {
let _x = 1;
[@attr1]
open Callbacks;
let _s = "hello" ++ "!";
[@attr2] Callbacks.("hello" ++ "!");
};
[@test.call string => string]
let processCommandItem = 12;
module type Foo = {
[@someattr]
let foo: int => int;
};
[@bs.deriving abstract]
type t = {
/** Position (in the pre-change coordinate system) where the change ended. */
[@bs.as "to"] [@bar]
to_: string,
};
[@bs.deriving abstract]
type editorConfiguration = {
/** Determines whether horizontal cursor movement through right-to-left (Arabic, Hebrew) text
is visual (pressing the left arrow moves the cursor left)
or logical (pressing the left arrow moves to the next lower index in the string, which is visually right in right-to-left text).
The default is false on Windows, and true on other platforms. */
[@bs.optional]
rtlMoveVisually: bool,
};
module Fmt = {
let barBaz = () => ();
type record = {x: int};
};
Fmt.([@foo] barBaz());
Fmt.([@foo] { x: 1 });
Fmt.([@foo] [1, 2, 3]);
Fmt.([@foo] (1, 2, 3));
Fmt.([@foo] { val x = 10 });
/**
* Attributes are associate with the identifier, function call, constructor
* appcation or constructor application pattern in front of it - up until a
* type constraint, an | (or) or an 'as'.
*/
let punnned_lbl_a = (~lbl as [@ATTR] lbl) => lbl;
let punnned_lbl_b = (~lbl as [@ATTR] (lbl: int)) => lbl;
let punnned_lbl_c =
(~lbl as [@ATTR] [@ATTR2] lbl) => lbl;
let punnned_lbl_d =
(~lbl as [@ATTR] ([@ATTR2] lbl: int)) => lbl;
let punnned_lbl_e =
(~lbl as [@ATTR] [@ATTR2] (lbl: int)) => lbl;
let punnned_lbl_f = (~lbl as [@ATTR] lbl: int) => lbl;
let punnned_lbl_g = (~lbl as [@ATTR] lbl: int) => lbl;
let punnned_lbl_h = (~lbl as [@ATTR] (lbl: int)) => lbl;
/** Attributes have lower precedence than type constraint. The following should
* be printed identically. */
let punnned_lbl_i = (~lbl as [@ATTR] lbl: int) => lbl;
let punnned_lbl_i' =
(~lbl as [@ATTR] (lbl: int)) => lbl;
let nonpunned_lbla =
(~lbl as [@ATTR] lblNonpunned) => lblNonpunned;
let nonpunned_lbl_b =
(~lbl as [@ATTR] (lblNonpunned: int)) => lblNonpunned;
let nonpunned_lbl_c =
(~lbl as [@ATTR] [@ATTR2] lblNonpunned) => lblNonpunned;
let nonpunned_lbl_d =
(
~lbl as
[@ATTR] ([@ATTR2] lblNonpunned: int),
) => lblNonpunned;
let nonpunned_lbl_e =
(
~lbl as
[@ATTR] [@ATTR2] (lblNonpunned: int),
) => lblNonpunned;
let nonpunned_lbl_f =
(~lbl as [@ATTR] lblNonpunned: int) => lblNonpunned;
let nonpunned_lbl_g =
(~lbl as [@ATTR] lblNonpunned: int) => lblNonpunned;
let nonpunned_lbl_h =
(~lbl as [@ATTR] (lblNonpunned: int)) => lblNonpunned;
let nonpunned_lbl_i =
(~lbl as [@ATTR] lblNonpunned: int) => lblNonpunned;
let nonpunned_lbl_i' =
(~lbl as [@ATTR] (lblNonpunned: int)) => lblNonpunned;
let defaulted_punnned_lbl_a =
(~lbl as [@ATTR] lbl=0, ()) => lbl;
let defaulted_punnned_lbl_b =
(~lbl as [@ATTR] (lbl: int)=0, ()) => lbl;
let defaulted_punnned_lbl_c =
(~lbl as [@ATTR] [@ATTR2] lbl=0, ()) => lbl;
let defaulted_punnned_lbl_d =
(~lbl as [@ATTR] ([@ATTR2] lbl: int)=0, ()) => lbl;
let defaulted_punnned_lbl_e =
(~lbl as [@ATTR] [@ATTR2] (lbl: int)=0, ()) => lbl;
let defaulted_punnned_lbl_f =
(~lbl as [@ATTR] lbl: int=0, ()) => lbl;
let defaulted_punnned_lbl_g =
(~lbl as [@ATTR] lbl: int=0, ()) => lbl;
let defaulted_punnned_lbl_h =
(~lbl as [@ATTR] (lbl: int)=0, ()) => lbl;
/** Attributes have lower precedence than type constraint. The following should
* be printed identically. */
let defaulted_punnned_lbl_i =
(~lbl as [@ATTR] lbl: int=0, ()) => lbl;
let defaulted_punnned_lbl_i' =
(~lbl as [@ATTR] (lbl: int)=0, ()) => lbl;
let defaulted_nonpunned_lbla =
(~lbl as [@ATTR] lblNonpunned=0, ()) => lblNonpunned;
let defaulted_nonpunned_lbl_b =
(~lbl as [@ATTR] (lblNonpunned: int)=0, ()) => lblNonpunned;
let defaulted_nonpunned_lbl_c =
(
~lbl as [@ATTR] [@ATTR2] lblNonpunned=0,
(),
) => lblNonpunned;
let defaulted_nonpunned_lbl_d =
(
~lbl as [@ATTR] ([@ATTR2] lblNonpunned: int)=0,
(),
) => lblNonpunned;
let defaulted_nonpunned_lbl_e =
(
~lbl as [@ATTR] [@ATTR2] (lblNonpunned: int)=0,
(),
) => lblNonpunned;
let defaulted_nonpunned_lbl_f =
(~lbl as [@ATTR] lblNonpunned: int=0, ()) => lblNonpunned;
let defaulted_nonpunned_lbl_g =
(~lbl as [@ATTR] lblNonpunned: int=0, ()) => lblNonpunned;
let defaulted_nonpunned_lbl_h =
(~lbl as [@ATTR] (lblNonpunned: int)=0, ()) => lblNonpunned;
let defaulted_nonpunned_lbl_i =
(~lbl as [@ATTR] lblNonpunned: int=0, ()) => lblNonpunned;
let defaulted_nonpunned_lbl_i' =
(~lbl as [@ATTR] (lblNonpunned: int)=0, ()) => lblNonpunned;
/* Won't parse: let [@attr] x1 : int = xInt; */
let xInt = 0;
/**
Attribute on the pattern node inside of constraint
pattern (
Ppat_constraint(
pattern(@xxx, Ppat_var "x"),
coretype
)
)
This will get sugared to `let ([@attr] x2) : int = xInt`
*/
let (([@attr] x2): int) = xInt;
/**
Attribute on the pattern holding the constraint:
pattern(
@xxx
Ppat_constraint(
pattern(Pexpident "x"),
coretype
)
)
*/
let [@attr] (x3: int) = xInt;
let [@attr] ([@attr0] x4: int) = xInt;
let [@attr] ([@attr0] x5: int) = xInt;
type eitherOr('a, 'b) =
| Either('a)
| Or('b);
let [@attr] Either(a) | Or(a) = Either("hi");
// Can drop the the parens around Either.
let [@attr] Either(a) | Or(a) = Either("hi");
// Can drop the parens around Or.
let Either(b) | [@attr] Or(b) = Either("hi");
// Should keep the parens around both
let [@attr] (Either(a) | Or(a)) = Either("hi");
// Should keep the parens
let [@attr] (_x as xAlias) = 10;
// Should drop the parens
let [@attr] _x as xAlias' = 10;
/**
Attribute on the expression node inside of constraint
expression(
Pexp_constraint(
expression(@xxx, Pexpident "x"),
coretype
)
)
*/
let _ = ([@xxx] xInt: int); // This should format the same
let _ = ([@xxx] xInt: int); // This should format the same
/**
Attribute on the expression holding the constraint:
expression(
@xxx
Pexp_constraint(
expression(Pexpident "x"),
coretype
)
)
*/
let _ = [@xxx] (xInt: int); // This should format the same
[@foo? [@attr] (x: int)];
[@foo? [@attr] ([@bar] x: int)];
[@foo? [@attr] (Either("hi") | Or("hi"))];
Type-check basics
$ ocamlc -c -pp 'refmt --print binary' -intf-suffix .rei -impl formatted.re
File "formatted.re", line 507, characters 4-10:
507 | concat;
^^^^^^
Warning 10 [non-unit-statement]: this expression should have type unit.
Format the formatted file back
$ refmt --print re ./formatted.re > ./formatted_back.re
Ensure idempotency: first format and second format are the same
$ diff formatted.re formatted_back.re
================================================
FILE: test/4.12/dune
================================================
; Disable these tests in windows since their output don't match, and we
; want to ensure the output works in other systems
(cram
(enabled_if
(and
(or
(= %{system} "macosx")
(= %{system} "linux"))
(or
(= %{ocaml_version} 4.12.0)
(= %{ocaml_version} 4.12.1)))))
================================================
FILE: test/4.12/local-openings.t/input.ml
================================================
module Foo = struct
type t = { name: string }
end
let foo Foo.{name} = ()
let f = function
| Foo.{name} -> ()
| _ -> ()
let x = { Foo.name = "Reason" }
let Foo.{name} = x
let Foo.{name}, _ = x, ()
================================================
FILE: test/4.12/local-openings.t/run.t
================================================
Format basic
$ refmt --print re ./input.ml > ./formatted.re
Type-check basics
$ ocamlc -c -pp 'refmt --print binary' -intf-suffix .rei -impl formatted.re
File "formatted.re", line 10, characters 2-5:
10 | | _ => ();
^^^
Warning 11 [redundant-case]: this match case is unused.
Format the formatted file back
$ refmt --print re ./formatted.re > ./formatted_back.re
Ensure idempotency: first format and second format are the same
$ diff formatted.re formatted_back.re
================================================
FILE: test/4.12/reasonComments-re.t/input.re
================================================
3; /* - */
3 /*-*/
;
3/*-*/
;
3/*-*/;
/* **** comment */
/*** comment */
/** docstring */
/* comment */
/** docstring */
/*** comment */
/**** comment */
/***** comment */
/** */
/*** */
/**** */
/**/
/***/
/****/
/** (** comment *) */
/** (*** comment *) */
/* (** comment *) */
/* (*** comment *) */
/* *(*** comment *) */
/* comment **/
/* comment ***/
/* comment ****/
/* comment *****/
/**
* Multiline
*/
/** Multiline
*
*/
/**
**
*/
module JustString = {
include Map.Make(Int32); /* Comment eol include */
};
let testingEndOfLineComments =
[
"Item 1" /* Comment For First Item */,
"Item 2" /* Comment For Second Item */,
"Item 3" /* Comment For Third Item */,
"Item 4" /* Comment For Fourth Item - but before trailing comma */,
/* Comment after last item in list. */
] /* Comment after rbracket */;
/* But if you place them after the comma at eol, they're preserved as such */
let testingEndOfLineComments =
[
"Item 1", /* Comment For First Item */
"Item 2", /* Comment For Second Item */
"Item 3", /* Comment For Third Item */
"Item 4" /* Comment For Fourth Item - but before trailing comma */,
/* Comment after last item in list. */
] /* Comment after rbracket */ ;
/* The space between ; and comment shoudn't matter */
let testPlacementOfTrailingComment = [
"Item 0" /* */
/* Comment after last item in list. */
]; /* Comment after semi */
/* The space between ; and comment shoudn't matter */
let testPlacementOfTrailingComment = [
"Item 0" /* */
/* Comment after last item in list. */
];/* Comment after semi */
/* Try again but without other things in the list */
let testPlacementOfTrailingComment = [
"Item 0" /* */
]; /* Comment after semi */
/* The space between ; and comment shoudn't matter */
let testPlacementOfTrailingComment = [
"Item 0" /* */
/* Comment after last item in list. */
];/* Comment after semi */
let testingEndOfLineComments = [];/* Comment after entire let binding */
/* The following is not yet idempotent */
/* let myFunction */
/* withFirstArg /* First arg */ */
/* andSecondArg => { /* Second Arg */ */
/* withFirstArg + andSecondArg /* before semi */ ; */
/* }; */
let myFunction
(/* First arg */
withFirstArg,
/* Second Arg */
andSecondArg) {
withFirstArg + andSecondArg
}; /* After Semi */
type point = {
x: string, /* x field */
y: string, /* y field */
};
type pointWithManyKindsOfComments = {
/* Line before x */
x: string, /* x field */
/* Line before y */
y: string, /* y field */
/* Final row of record */
};
type typeParamPointWithComments('a) = {
/* Line before x */
x: 'a, /* x field */
/* Line before y */
y: 'a /* y field */
/* Final row of record */
};
/* Now, interleaving comments in type params */
type
/* Type name */
typeParamPointWithComments2(
/* The a type param */
'a,
/* The b type apram */
'b) = {
/* Line before x */
x: 'a, /* x field */
/* Line before y */
y: 'a /* y field */
/* Final row of record */
};
/* The way the last row comment is formatted is suboptimal becuase
* record type definitions do not include enough location information */
type anotherpoint = {
x: string, /* x field */
y: string, /* y field */
/* comment as last row of record */
};
type t = (int, int); /* End of line on t */
type t2 =
(int, int) /* End of line on (int, int) */
;
type t3 =
(int, int); /* End of line on (int, int) */
type variant =
| X (int, int) /* End of line on X */
| Y (int, int) /* End of line on Y */
; /* Comment on entire type def for variant */
/* Before let */
let res =
/* Before switch */
switch (X (2, 3)) {
/* Above X line */
| X(_) => "result of X" /* End of arrow and X line */
/* Above Y line */
| Y(_) => "result of Y" /* End of arrow and Y line */
}; /* After final semi in switch */
let res =
switch (X (2, 3)) {
| X (0, 0) => /* After X arrow */
"result of X" /* End of X body line */
| X (1, 0) /* Before X's arrow */ =>
"result of X" /* End of X body line */
| X (_) => /* After X _ arrow */
"result of X" /* End of X body line */
/* Above Y line */
| Y (_) =>
/* Comment above Y body */
"result of Y"
};
type variant2 =
/* Comment above X */
| X (int, int) /* End of line on X */
/* Comment above Y */
| Y (int, int);
type variant3 =
/* Comment above X */
| X (int, int) /* End of line on X */
/* Comment above Y */
| Y (int, int) /* End of line on Y */
;
type x = { /* not attached *above* x */
fieldOne : int,
fieldA : int
} /* Attached end of line after x */
and y = { /* not attached *above* y */
fieldTwo : int
} /* Attached end of line after y */
;
type x2 = { /* not attached *above* x2 */
fieldOne : int,
fieldA : int
} /* Attached end of line after x2 */
and y2 = { /* not attached *above* y2 */
fieldTwo : int
};
let result =
switch (None) {
| Some({fieldOne: 20, fieldA:a})=> /* Where does this comment go? */
let tmp = 0;
2 + tmp
| Some {fieldOne: n, fieldA:a} =>
/* How about this one */
let tmp = n;
n + tmp
| None => 20
};
let res =
/* Before switch */
switch (X (2, 3)) {
/* Above X line */
| X(_) => "result of X" /* End of arrow and X line */
/* Above Y line */
| Y(_) => "result of Y" /* End of arrow and Y line */
};
/*
* Now these end of line comments *should* be retained.
*/
let result = switch (None) {
| Some {
fieldOne: 20, /* end of line */
fieldA:a /* end of line */
} =>
let tmp = 0;
2 + tmp
| Some {
fieldOne: n, /* end of line */
fieldA:a /* end of line */
} =>
let tmp = n;
n + tmp
| None => 20
};
/*
* These end of line comments *should* be retained.
* To get the simple expression eol comment to be retained, we just need to
* implement label breaking eol behavior much like we did with sequences.
* Otherwise, right now they are not idempotent.
*/
let res =
switch ( /* Retain this */
X (2, 3)
)
{
/* Above X line */
| X (
_, /* retain this */
_ /* retain this */
) => "result of X"
/* Above Y line */
| Y(_) => "result of Y" /* End of arrow and Y line */
};
type optionalTuple =
| OptTup (
option ((
int, /* First int */
int /* Second int */
))
);
type optionTuple =
option ((
int, /* First int */
int /* Second int */
));
type intPair = (
int, /* First int */
int /* Second int */
);
type intPair2 = (
/* First int */
int,
/* Second int */
int
);
let result = {
/**/
(+)(2,3)
};
/* This is not yet idempotent */
/* { */
/* /**/ */
/* (+) 2 3 */
/* }; */
let a = ();
for (i in 0 to 10) {
/* bla */
a
};
if (true) {
/* hello */
()
};
type color =
| Red(int) /* After red end of line */
| Black(int) /* After black end of line */
| Green(int) /* After green end of line */
; /* On next line after color type def */
let blahCurriedX(x) =
fun
| Red(10)
| Black(20)
| Green(10) => 1 /* After or pattern green */
| Red(x) => 0 /* After red */
| Black(x) => 0 /* After black */
| Green(x) => 0 /* After second green */
; /* On next line after blahCurriedX def */
let name_equal(x,y) { x == y };
let equal(i1,i2) =
i1.contents === i2.contents && true; /* most unlikely first */
let equal(i1,i2) =
compare(compare(0,0),compare(1,1)); /* END OF LINE HERE */
let tuple_equal((i1, i2)) = i1 == i2;
let tuple_equal((csu, mgd)) =
/* Some really long comments, see https://github.com/facebook/reason/issues/811 */
tuple_equal((csu, mgd));
/** Comments inside empty function bodies
* See https://github.com/facebook/reason/issues/860
*/
let fun_def_comment_inline = () => { /* */ };
let fun_def_comment_newline = () => {
/* */
};
let fun_def_comment_long = () => { /* longer comment inside empty function body */};
let trueThing = true;
for (i in 0 to 1) {
/* comment */
print_newline();
};
while (trueThing) {
/* comment */
print_newline();
};
if (trueThing) {
/* comment */
print_newline()
};
/* Comment before if test */
if (trueThing) {
/* Comment before print */
print_newline();
/* Comment before print */
print_newline();
/* Comment after final print */
};
/* Comment before if test */
if (trueThing) {
/* Comment before print */
print_newline();
/* Comment after final print */
};
/* Comment before if test */
if (trueThing) {
/* Comment before print */
print_newline();
/* Comment before print */
print_newline();
/* Comment after final print */
} else {
/* Comment before print */
print_newline();
/* Comment before print */
print_newline();
/* Comment after final print */
};
/* Comment before if test */
if (trueThing) {
/* Comment before print */
print_newline();
/* Comment after final print */
} else {
/* Comment before print */
print_newline();
/* Comment after final print */
};
/* Comment before while test */
while (trueThing) {
/* Comment before print */
print_newline();
/* Comment before print */
print_newline();
/* Comment after final print */
};
/* Comment before while test */
while (trueThing) {
/* Comment before print */
print_newline();
/* Comment after final print */
};
/* Comment before for test */
for (i in 0 to 100) {
/* Comment before print */
print_newline();
/* Comment before print */
print_newline();
/* Comment after final print */
};
/* Comment before for test */
for (i in 0 to 100) {
/* Comment before print */
print_newline();
/* Comment after final print */
};
if (trueThing) {
/* Comment before print */
print_newline(); /* eol print */
/* Comment before print */
print_newline(); /* eol print */
/* Comment after print */
};
/* Comment before if test */
if (trueThing) {
/* Comment before print */
print_newline(); /* eol print */
/* Comment after print */
};
/* Comment before if test */
if (trueThing) {
/* Comment before print */
print_newline(); /* eol print */
/* Comment before print */
print_newline(); /* eol print */
/* Comment after print */
} else {
/* Comment before print */
print_newline(); /* eol print */
/* Comment before print */
print_newline(); /* eol print */
/* Comment after print */
};
/* Comment before if test */
if (trueThing) {
/* Comment before print */
print_newline(); /* eol print */
/* Comment before print */
} else {
/* Comment before print */
print_newline(); /* eol print */
/* Comment before print */
print_newline(); /* eol print */
/* Comment after print */
};
/* Comment before while test */
while (trueThing) {
/* Comment before print */
print_newline(); /* eol */
/* Comment before print */
print_newline(); /* eol */
/* Comment after final print */
};
/* Comment before while test */
while (trueThing) {
/* Comment before print */
print_newline(); /* eol */
/* Comment after final print */
};
/* Comment before for test */
for (i in 0 to 100) {
/* Comment before print */
print_newline(); /* eol */
/* Comment before print */
print_newline(); /* eol */
/* Comment after final print */
};
/* Comment before for test */
for (i in 0 to 100) {
/* Comment before print */
print_newline(); /* eol */
/* Comment after final print */
};
let f = (a, b, c, d) => a + b + c + d;
while(trueThing) {
f(
/* a */
1,
/* b */
2,
/* c */
3,
/* d */
4
/* does work */
);
};
while(trueThing) {
f(
/* a */
1,
/* b */
2,
/* c */
3,
/* d */
4 /* does work */
);
};
ignore((_really, _long, _printWidth, _exceeded, _here) => {
/* First comment */
let x = 0;
x + x;
/* Closing comment */
});
ignore((_xxx, _yyy) => {
/* First comment */
let x = 0;
x + x;
/* Closing comment */
});
type tester('a, 'b) = | TwoArgsConstructor('a, 'b) | OneTupleArgConstructor(('a, 'b));
let callFunctionTwoArgs = (a, b) => ();
let callFunctionOneTuple = (tuple) => ();
let y = TwoArgsConstructor(
1, /*eol1*/
2 /* eol2 */
);
let y = callFunctionTwoArgs(
1, /*eol1*/
2 /* eol2 */
);
let y = OneTupleArgConstructor((
1, /*eol1*/
2 /* eol2 */
));
let y = callFunctionOneTuple((
1, /*eol1*/
2 /* eol2 */
));
type polyRecord('a, 'b) = {fieldOne: 'a, fieldTwo: 'b};
let r = {
fieldOne: 1, /*eol1*/
fieldTwo: 2 /* eol2 */
};
let r = {
fieldOne: 1, /*eol1*/
fieldTwo: 2, /* eol2 with trailing comma */
};
let y = TwoArgsConstructor(
"1", /*eol1*/
"2" /* eol2 */
);
let y = callFunctionTwoArgs(
"1", /*eol1*/
"2" /* eol2 */
);
let y = OneTupleArgConstructor((
"1", /*eol1*/
"2" /* eol2 */
));
let y = callFunctionOneTuple((
"1", /*eol1*/
"2" /* eol2 */
));
let r = {
fieldOne: "1", /*eol1*/
fieldTwo: "2" /* eol2 */
};
let r = {
fieldOne: "1", /*eol1*/
fieldTwo: "2", /* eol2 with trailing comma */
};
let identifier = "hello";
let y = TwoArgsConstructor(
identifier, /*eol1*/
identifier /* eol2 */
);
let y = callFunctionTwoArgs(
identifier , /*eol1*/
identifier /* eol2 */
);
let y = OneTupleArgConstructor((
identifier , /*eol1*/
identifier /* eol2 */
));
let y = callFunctionOneTuple((
identifier , /*eol1*/
identifier /* eol2 */
));
let r = {
fieldOne: identifier, /*eol1*/
fieldTwo: identifier /* eol2 */
};
let r = {
fieldOne: identifier, /*eol1*/
fieldTwo: identifier, /* eol2 with trailing comma */
};
let y = TwoArgsConstructor(
identifier : string, /*eol1*/
identifier : string/* eol2 */
);
let y = callFunctionTwoArgs(
identifier : string , /*eol1*/
identifier : string /* eol2 */
);
let y = OneTupleArgConstructor((
identifier : string , /*eol1*/
identifier : string /* eol2 */
));
let y = callFunctionOneTuple((
identifier : string , /*eol1*/
identifier : string /* eol2 */
));
let r = {
fieldOne: (identifier : string), /*eol1*/
fieldTwo: (identifier : string) /* eol2 */
};
let r = {
fieldOne: (identifier : string), /*eol1*/
fieldTwo: (identifier : string), /* eol2 with trailing comma */
};
/** doc comment */
[@bs.send]
external url : t => string = "";
/**
* Short multiline doc comment
*/
[@bs.send]
external url : t => string = "";
/** Longer doc comment before an attribute on an external. */
[@bs.send]
external url : t => string = "";
/* normal comment */
[@bs.send] external url : t => string = "";
/** doc type */
type q = {a: int, b: string};
/** doc let */
let letter : q = {a: 42, b: "answer"};
================================================
FILE: test/4.12/reasonComments-re.t/run.t
================================================
Format basic
$ refmt --print re ./input.re > ./formatted.re
Print the formatted file
$ cat ./formatted.re
3; /* - */
3; /*-*/
3; /*-*/
3 /*-*/;
/* **** comment */
/*** comment */
/** docstring */
/* comment */
/** docstring */
/*** comment */
/**** comment */
/***** comment */
/** */
/*** */
/**** */
/**/
/***/
/****/
/** (** comment *) */
/** (*** comment *) */
/* (** comment *) */
/* (*** comment *) */
/* *(*** comment *) */
/* comment **/
/* comment ***/
/* comment ****/
/* comment *****/
/**
* Multiline
*/
/** Multiline
*
*/
/**
**
*/
module JustString = {
include Map.Make(Int32); /* Comment eol include */
};
let testingEndOfLineComments = [
"Item 1" /* Comment For First Item */,
"Item 2" /* Comment For Second Item */,
"Item 3" /* Comment For Third Item */,
"Item 4" /* Comment For Fourth Item - but before trailing comma */,
/* Comment after last item in list. */
] /* Comment after rbracket */;
/* But if you place them after the comma at eol, they're preserved as such */
let testingEndOfLineComments = [
"Item 1", /* Comment For First Item */
"Item 2", /* Comment For Second Item */
"Item 3", /* Comment For Third Item */
"Item 4" /* Comment For Fourth Item - but before trailing comma */,
/* Comment after last item in list. */
] /* Comment after rbracket */;
/* The space between ; and comment shoudn't matter */
let testPlacementOfTrailingComment = [
"Item 0" /* */
/* Comment after last item in list. */
]; /* Comment after semi */
/* The space between ; and comment shoudn't matter */
let testPlacementOfTrailingComment = [
"Item 0" /* */
/* Comment after last item in list. */
]; /* Comment after semi */
/* Try again but without other things in the list */
let testPlacementOfTrailingComment = [
"Item 0" /* */
]; /* Comment after semi */
/* The space between ; and comment shoudn't matter */
let testPlacementOfTrailingComment = [
"Item 0" /* */
/* Comment after last item in list. */
]; /* Comment after semi */
let testingEndOfLineComments = []; /* Comment after entire let binding */
/* The following is not yet idempotent */
/* let myFunction */
/* withFirstArg /* First arg */ */
/* andSecondArg => { /* Second Arg */ */
/* withFirstArg + andSecondArg /* before semi */ ; */
/* }; */
let myFunction = /* First arg */
(
withFirstArg,
/* Second Arg */
andSecondArg,
) => {
withFirstArg + andSecondArg;
}; /* After Semi */
type point = {
x: string, /* x field */
y: string /* y field */
};
type pointWithManyKindsOfComments = {
/* Line before x */
x: string, /* x field */
/* Line before y */
y: string /* y field */
/* Final row of record */
};
type typeParamPointWithComments('a) = {
/* Line before x */
x: 'a, /* x field */
/* Line before y */
y: 'a /* y field */
/* Final row of record */
};
/* Now, interleaving comments in type params */
/* Type name */
type typeParamPointWithComments2
/* The a type param */
(
'a,
/* The b type apram */
'b,
) = {
/* Line before x */
x: 'a, /* x field */
/* Line before y */
y: 'a /* y field */
/* Final row of record */
};
/* The way the last row comment is formatted is suboptimal becuase
* record type definitions do not include enough location information */
type anotherpoint = {
x: string, /* x field */
y: string /* y field */
/* comment as last row of record */
};
type t = (int, int); /* End of line on t */
type t2 = (int, int); /* End of line on (int, int) */
type t3 = (int, int); /* End of line on (int, int) */
type variant =
| X(int, int) /* End of line on X */
| Y(int, int); /* End of line on Y */ /* Comment on entire type def for variant */
/* Before let */
let res =
/* Before switch */
switch (X(2, 3)) {
/* Above X line */
| X(_) => "result of X" /* End of arrow and X line */
/* Above Y line */
| Y(_) => "result of Y" /* End of arrow and Y line */
}; /* After final semi in switch */
let res =
switch (X(2, 3)) {
| X(0, 0) =>
/* After X arrow */
"result of X" /* End of X body line */
| X(1, 0) /* Before X's arrow */ => "result of X" /* End of X body line */
| X(_) =>
/* After X _ arrow */
"result of X" /* End of X body line */
/* Above Y line */
| Y(_) =>
/* Comment above Y body */
"result of Y"
};
type variant2 =
/* Comment above X */
| X(int, int) /* End of line on X */
/* Comment above Y */
| Y(int, int);
type variant3 =
/* Comment above X */
| X(int, int) /* End of line on X */
/* Comment above Y */
| Y(int, int); /* End of line on Y */
type x = {
/* not attached *above* x */
fieldOne: int,
fieldA: int,
} /* Attached end of line after x */
and y = {
/* not attached *above* y */
fieldTwo: int,
}; /* Attached end of line after y */
type x2 = {
/* not attached *above* x2 */
fieldOne: int,
fieldA: int,
} /* Attached end of line after x2 */
and y2 = {
/* not attached *above* y2 */
fieldTwo: int,
};
let result =
switch (None) {
| Some({ fieldOne: 20, fieldA: a }) =>
/* Where does this comment go? */
let tmp = 0;
2 + tmp;
| Some({ fieldOne: n, fieldA: a }) =>
/* How about this one */
let tmp = n;
n + tmp;
| None => 20
};
let res =
/* Before switch */
switch (X(2, 3)) {
/* Above X line */
| X(_) => "result of X" /* End of arrow and X line */
/* Above Y line */
| Y(_) => "result of Y" /* End of arrow and Y line */
};
/*
* Now these end of line comments *should* be retained.
*/
let result =
switch (None) {
| Some({
fieldOne: 20, /* end of line */
fieldA: a /* end of line */
}) =>
let tmp = 0;
2 + tmp;
| Some({
fieldOne: n, /* end of line */
fieldA: a /* end of line */
}) =>
let tmp = n;
n + tmp;
| None => 20
};
/*
* These end of line comments *should* be retained.
* To get the simple expression eol comment to be retained, we just need to
* implement label breaking eol behavior much like we did with sequences.
* Otherwise, right now they are not idempotent.
*/
let res =
switch (
/* Retain this */
X(2, 3)
) {
/* Above X line */
| X(
_, /* retain this */
_ /* retain this */
) => "result of X"
/* Above Y line */
| Y(_) => "result of Y" /* End of arrow and Y line */
};
type optionalTuple =
| OptTup(
option(
(
int, /* First int */
int /* Second int */
),
),
);
type optionTuple =
option(
(
int, /* First int */
int /* Second int */
),
);
type intPair = (
int, /* First int */
int /* Second int */
);
type intPair2 = (
/* First int */
int,
/* Second int */
int,
);
let result =
/**/
{
2 + 3;
};
/* This is not yet idempotent */
/* { */
/* /**/ */
/* (+) 2 3 */
/* }; */
let a = ();
for (i in 0 to 10) {
/* bla */
a;
};
if (true) {
/* hello */
()
};
type color =
| Red(int) /* After red end of line */
| Black(int) /* After black end of line */
| Green(int); /* After green end of line */ /* On next line after color type def */
let blahCurriedX = x =>
fun
| Red(10)
| Black(20)
| Green(10) => 1 /* After or pattern green */
| Red(x) => 0 /* After red */
| Black(x) => 0 /* After black */
| Green(x) => 0; /* After second green */ /* On next line after blahCurriedX def */
let name_equal = (x, y) => {
x == y;
};
let equal = (i1, i2) =>
i1.contents === i2.contents && true; /* most unlikely first */
let equal = (i1, i2) =>
compare(compare(0, 0), compare(1, 1)); /* END OF LINE HERE */
let tuple_equal = ((i1, i2)) => i1 == i2;
let tuple_equal = ((csu, mgd)) =>
/* Some really long comments, see https://github.com/facebook/reason/issues/811 */
tuple_equal((csu, mgd));
/** Comments inside empty function bodies
* See https://github.com/facebook/reason/issues/860
*/
let fun_def_comment_inline = () => {/* */};
let fun_def_comment_newline = () => {/* */};
let fun_def_comment_long = () => {
/* longer comment inside empty function body */
};
let trueThing = true;
for (i in 0 to 1) {
/* comment */
print_newline();
};
while (trueThing) {
/* comment */
print_newline();
};
if (trueThing) {
/* comment */
print_newline();
};
/* Comment before if test */
if (trueThing) {
/* Comment before print */
print_newline();
/* Comment before print */
print_newline();
/* Comment after final print */
};
/* Comment before if test */
if (trueThing) {
/* Comment before print */
print_newline();
/* Comment after final print */
};
/* Comment before if test */
if (trueThing) {
/* Comment before print */
print_newline();
/* Comment before print */
print_newline();
/* Comment after final print */
} else {
/* Comment before print */
print_newline();
/* Comment before print */
print_newline();
/* Comment after final print */
};
/* Comment before if test */
if (trueThing) {
/* Comment before print */
print_newline();
/* Comment after final print */
} else {
/* Comment before print */
print_newline();
/* Comment after final print */
};
/* Comment before while test */
while (trueThing) {
/* Comment before print */
print_newline();
/* Comment before print */
print_newline();
/* Comment after final print */
};
/* Comment before while test */
while (trueThing) {
/* Comment before print */
print_newline();
/* Comment after final print */
};
/* Comment before for test */
for (i in 0 to 100) {
/* Comment before print */
print_newline();
/* Comment before print */
print_newline();
/* Comment after final print */
};
/* Comment before for test */
for (i in 0 to 100) {
/* Comment before print */
print_newline();
/* Comment after final print */
};
if (trueThing) {
/* Comment before print */
print_newline(); /* eol print */
/* Comment before print */
print_newline(); /* eol print */
/* Comment after print */
};
/* Comment before if test */
if (trueThing) {
/* Comment before print */
print_newline(); /* eol print */
/* Comment after print */
};
/* Comment before if test */
if (trueThing) {
/* Comment before print */
print_newline(); /* eol print */
/* Comment before print */
print_newline(); /* eol print */
/* Comment after print */
} else {
/* Comment before print */
print_newline(); /* eol print */
/* Comment before print */
print_newline(); /* eol print */
/* Comment after print */
};
/* Comment before if test */
if (trueThing) {
/* Comment before print */
print_newline(); /* eol print */
/* Comment before print */
} else {
/* Comment before print */
print_newline(); /* eol print */
/* Comment before print */
print_newline(); /* eol print */
/* Comment after print */
};
/* Comment before while test */
while (trueThing) {
/* Comment before print */
print_newline(); /* eol */
/* Comment before print */
print_newline(); /* eol */
/* Comment after final print */
};
/* Comment before while test */
while (trueThing) {
/* Comment before print */
print_newline(); /* eol */
/* Comment after final print */
};
/* Comment before for test */
for (i in 0 to 100) {
/* Comment before print */
print_newline(); /* eol */
/* Comment before print */
print_newline(); /* eol */
/* Comment after final print */
};
/* Comment before for test */
for (i in 0 to 100) {
/* Comment before print */
print_newline(); /* eol */
/* Comment after final print */
};
let f = (a, b, c, d) => a + b + c + d;
while (trueThing) {
f(
/* a */
1,
/* b */
2,
/* c */
3,
/* d */
4,
/* does work */
);
};
while (trueThing) {
f(
/* a */
1,
/* b */
2,
/* c */
3,
/* d */
4 /* does work */
);
};
ignore(
(
_really,
_long,
_printWidth,
_exceeded,
_here,
) => {
/* First comment */
let x = 0;
x + x;
/* Closing comment */
});
ignore((_xxx, _yyy) => {
/* First comment */
let x = 0;
x + x;
/* Closing comment */
});
type tester('a, 'b) =
| TwoArgsConstructor('a, 'b)
| OneTupleArgConstructor(('a, 'b));
let callFunctionTwoArgs = (a, b) => ();
let callFunctionOneTuple = tuple => ();
let y =
TwoArgsConstructor(
1, /*eol1*/
2 /* eol2 */
);
let y =
callFunctionTwoArgs(
1, /*eol1*/
2 /* eol2 */
);
let y =
OneTupleArgConstructor((
1, /*eol1*/
2 /* eol2 */
));
let y =
callFunctionOneTuple((
1, /*eol1*/
2 /* eol2 */
));
type polyRecord('a, 'b) = {
fieldOne: 'a,
fieldTwo: 'b,
};
let r = {
fieldOne: 1, /*eol1*/
fieldTwo: 2 /* eol2 */
};
let r = {
fieldOne: 1, /*eol1*/
fieldTwo: 2 /* eol2 with trailing comma */
};
let y =
TwoArgsConstructor(
"1", /*eol1*/
"2" /* eol2 */
);
let y =
callFunctionTwoArgs(
"1", /*eol1*/
"2" /* eol2 */
);
let y =
OneTupleArgConstructor((
"1", /*eol1*/
"2" /* eol2 */
));
let y =
callFunctionOneTuple((
"1", /*eol1*/
"2" /* eol2 */
));
let r = {
fieldOne: "1", /*eol1*/
fieldTwo: "2" /* eol2 */
};
let r = {
fieldOne: "1", /*eol1*/
fieldTwo: "2" /* eol2 with trailing comma */
};
let identifier = "hello";
let y =
TwoArgsConstructor(
identifier, /*eol1*/
identifier /* eol2 */
);
let y =
callFunctionTwoArgs(
identifier, /*eol1*/
identifier /* eol2 */
);
let y =
OneTupleArgConstructor((
identifier, /*eol1*/
identifier /* eol2 */
));
let y =
callFunctionOneTuple((
identifier, /*eol1*/
identifier /* eol2 */
));
let r = {
fieldOne: identifier, /*eol1*/
fieldTwo: identifier /* eol2 */
};
let r = {
fieldOne: identifier, /*eol1*/
fieldTwo: identifier /* eol2 with trailing comma */
};
let y =
TwoArgsConstructor(
identifier: string, /*eol1*/
identifier: string /* eol2 */
);
let y =
callFunctionTwoArgs(
identifier: string, /*eol1*/
identifier: string /* eol2 */
);
let y =
OneTupleArgConstructor((
identifier: string, /*eol1*/
identifier: string /* eol2 */
));
let y =
callFunctionOneTuple((
identifier: string, /*eol1*/
identifier: string /* eol2 */
));
let r = {
fieldOne: (identifier: string), /*eol1*/
fieldTwo: (identifier: string) /* eol2 */
};
let r = {
fieldOne: (identifier: string), /*eol1*/
fieldTwo: (identifier: string) /* eol2 with trailing comma */
};
/** doc comment */
[@bs.send]
external url: t => string;
/**
* Short multiline doc comment
*/
[@bs.send]
external url: t => string;
/** Longer doc comment before an attribute on an external. */
[@bs.send]
external url: t => string;
/* normal comment */
[@bs.send] external url: t => string;
/** doc type */
type q = {
a: int,
b: string,
};
/** doc let */
let letter: q = {
a: 42,
b: "answer",
};
Type-check basics
$ ocamlc -c -pp 'refmt --print binary' -intf-suffix .rei -impl formatted.re
File "formatted.re", lines 536-548, characters 18-1:
536 | ..................{
537 | f(
538 | /* a */
539 | 1,
540 | /* b */
...
545 | 4,
546 | /* does work */
547 | );
548 | }.
Warning 10 [non-unit-statement]: this expression should have type unit.
File "formatted.re", lines 549-560, characters 18-1:
549 | ..................{
550 | f(
551 | /* a */
552 | 1,
553 | /* b */
...
557 | /* d */
558 | 4 /* does work */
559 | );
560 | }.
Warning 10 [non-unit-statement]: this expression should have type unit.
Format the formatted file back
$ refmt --print re ./formatted.re > ./formatted_back.re
Ensure idempotency: first format and second format are the same
$ diff formatted.re formatted_back.re
================================================
FILE: test/4.12/type-jsx.t/input.re
================================================
type component = {displayName: string};
module Bar = {
let createElement(~c=?,~children,()) {displayName: "test"};
};
module Nesting = {
let createElement(~children,()) {displayName: "test"};
};
module Much = {
let createElement(~children,()) {displayName: "test"};
};
module Foo = {
let createElement(~a=?,~b=?,~children,()) {displayName: "test"};
};
module One = {
let createElement(~test=?,~foo=?,~children,()) {displayName: "test"};
let createElementobvioustypo(~test,~children,()) {displayName: "test"};
};
module Two = {
let createElement(~foo=?,~children,()) {displayName: "test"};
};
module Sibling = {
let createElement(~foo=?,~children : list(component),()) = {displayName: "test"};
};
module Test = {
let createElement(~yo=?,~children,()) {displayName: "test"};
};
module So = {
let createElement(~children,()) {displayName: "test"};
};
module Foo2 = {
let createElement(~children,()) {displayName: "test"};
};
module Text = {
let createElement(~children,()) {displayName: "test"};
};
module Exp = {
let createElement(~children,()) {displayName: "test"};
};
module Pun = {
let createElement(~intended=?,~children,()) {displayName: "test"};
};
module Namespace = {
module Foo = {
let createElement(~intended=?,~anotherOptional as x=100,~children,()) {displayName: "test"};
};
};
module Optional1 = {
let createElement(~required,~children,()) {
switch (required) {
| Some(a) => {displayName: a}
| None => {displayName: "nope"}
};
};
};
module Optional2 = {
let createElement(~optional=?,~children,()) {
switch (optional) {
| Some(a) => {displayName: a}
| None => {displayName: "nope"}
};
};
};
module DefaultArg = {
let createElement(~default=Some("foo"),~children,()) {
switch (default) {
| Some(a) => {displayName: a}
| None => {displayName: "nope"}
};
};
};
module LotsOfArguments = {
let createElement(~argument1=?,~argument2=?,~argument3=?,~argument4=?,~argument5=?,~argument6=?,~children,()) {displayName: "test"};
};
let div(~argument1=?,~children,()) {
displayName: "test"
};
module List1 = {
let createElement(~children,()) {displayName: "test"};
};
module List2 = {
let createElement(~children,()) {displayName: "test"};
};
module List3 = {
let createElement(~children,()) {displayName: "test"};
};
module NotReallyJSX = {
let createElement(~foo,~bar,children) {displayName: "test"};
};
let notReallyJSX(~foo,~bar,children) {
displayName: "test"
};
let fakeRender (el:component) {
el.displayName
};
/* end of setup */
let (/><)(a,b) = a + b;
let (><)(a,b) = a + b;
let (/>) = fun(a,b) => a + b;
let ( ><\/ ) = fun(a,b) => a + b;
let tag1 = 5 />< 6;
let tag2 = 5 >< 7;
let tag3 = 5 /> 7;
let tag4 = 5 ><\/ 7;
let b = 2;
let selfClosing = <Foo />;
let selfClosing2 = <Foo a=1 b=true />;
let selfClosing3 =
<Foo
a="really long values that should"
b="cause the entire thing to wrap"
/>;
let a = <Foo> <Bar c=((a) => a + 2) /> </Foo>;
let a3 = <So> <Much> <Nesting> </Nesting> </Much> </So>;
let a4 = <Sibling> <One test=true foo=b /> <Two foo=b> </Two> </Sibling>;
let a5 = <Foo>"testing a string here"</Foo>;
let a6 =
<Foo2>
<Text>
"testing a string here"</Text>
<Test yo=1 /> <Text>"another string"</Text> <Bar> </Bar> <Exp>( 2 + 4 )</Exp>
</Foo2>;
let intended = true;
let punning = <Pun intended />;
let namespace = <Namespace.Foo />;
let c = <Foo> </Foo>;
let d = <Foo> </Foo>;
let spaceBefore = <So> <Much> <Nesting> </Nesting> </Much> </So>;
let spaceBefore2 = <So> <Much/> </So>;
let siblingNotSpaced = <So> <Much> </Much> <Much> </Much> </So>;
let jsxInList = [ <Foo> </Foo>];
let jsxInList2 = [ <Foo />];
let jsxInListA = [ <Foo> </Foo> ];
let jsxInListB = [ <Foo /> ];
let jsxInListC = [ <Foo> </Foo>];
let jsxInListD = [ <Foo />];
let jsxInList3 = [ <Foo> </Foo>, <Foo> </Foo>, <Foo> </Foo>];
let jsxInList4 = [ <Foo />, <Foo />, <Foo />];
let jsxInList5 = [ <Foo> </Foo>, <Foo> </Foo> ];
let jsxInList6 = [ <Foo />, <Foo /> ];
let jsxInList7 = [ <Foo> </Foo>, <Foo> </Foo>];
let jsxInList8 = [ <Foo />, <Foo />];
let testFunc(b) = b;
let jsxInFnCall = testFunc (<Foo />);
let lotsOfArguments = <LotsOfArguments argument1=1 argument2=2 argument3=3 argument4=4 argument5=5 argument6="test"> <Namespace.Foo /> </LotsOfArguments>;
let lowerCase = <div argument1=1 />;
let b = 0;
let d = 0;
/*
* Should pun the first example:
*/
let a = <Foo a=a>5</Foo>;
let a = <Foo a=b>5</Foo>;
let a = <Foo a=b b=d>5</Foo>;
let a = <Foo a>0.55</Foo>;
let a = [@JSX] Foo.createElement(~children=[],());
let ident = <Foo>{a}</Foo>;
let fragment1 = <> <Foo /> <Foo /> </>;
let fragment2 = <> <Foo /> <Foo /> </>;
let fragment3 = <> <Foo /> <Foo /> </>;
let fragment4 = <> <Foo /> <Foo /> </>;
let fragment5 = <> <Foo> </Foo> <Foo> </Foo> </>;
let fragment6 = <> <Foo> </Foo> <Foo> </Foo> </>;
let fragment7 = <> <Foo> </Foo> <Foo> </Foo> </>;
let fragment8 = <> <Foo> </Foo> <Foo> </Foo> </>;
let fragment9 = <> 2 2 2 2 </>;
let fragment10 = <>2.2 3.2 4.6 1.2 </>;
let fragment11 = <>"str"</>;
let fragment12 = <>(6 + 2) (6 + 2) (6 + 2)</>;
let fragment13 = <>fragment11 fragment11</>;
let listOfItems1 = <List1>1 2 3 4 5</List1>;
let listOfItems2 = <List2>1.0 2.8 3.8 4.0 5.1</List2>;
let listOfItems3 = <List3>fragment11 fragment11</List3>;
/*
* Several sequential simple jsx expressions must be separated with a space.
*/
let thisIsRight(a,b) = ();
let tagOne = fun(~children,()) => ();
let tagTwo = fun(~children,()) => ();
/* thisIsWrong <tagOne /><tagTwo />; */
thisIsRight(<tagOne />,<tagTwo />);
/* thisIsWrong <tagOne> </tagOne><tagTwo> </tagTwo>; */
thisIsRight(<tagOne> </tagOne>, <tagTwo> </tagTwo>);
let a = fun(~children,()) => ();
let b = fun(~children,()) => ();
let thisIsOkay =
<List1>
<a> </a> <b> </b>
<a/> <b/>
</List1>;
let thisIsAlsoOkay =
<List1>
<a> </a> <b> </b>
</List1>;
/* Doesn't make any sense, but suppose you defined an
infix operator to compare jsx */
<a /> < <b />;
<a /> > <b />;
<a> </a> < <b> </b>;
<a> </a> > <b> </b>;
let listOfListOfJsx = [<> </>];
let listOfListOfJsx = [<> <Foo> </Foo> </>];
let listOfListOfJsx = [<> <Foo /> </>, <> <Bar /> </> ];
let listOfListOfJsx = [<> <Foo /> </>, <> <Bar /> </>, ...listOfListOfJsx];
let sameButWithSpaces = [ <> </>];
let sameButWithSpaces = [ <> <Foo /> </>];
let sameButWithSpaces = [ <> <Foo /> </>, <> <Bar /> </>];
let sameButWithSpaces = [ <> <Foo /> </>, <> <Bar /> </>, ...sameButWithSpaces];
/*
* Test named tag right next to an open bracket.
*/
let listOfJsx = [];
let listOfJsx = [<Foo> </Foo>];
let listOfJsx = [<Foo />, <Bar /> ];
let listOfJsx = [<Foo />, <Bar /> , ...listOfJsx];
let sameButWithSpaces = [];
let sameButWithSpaces = [<Foo />];
let sameButWithSpaces = [<Foo />, <Bar />];
let sameButWithSpaces = [<Foo />, <Bar />, ...sameButWithSpaces];
/**
* Test no conflict with polymorphic variant types.
*/
type thisType = [`Foo | `Bar];
type t('a) = [< thisType ] as 'a;
let asd = [@JSX] [@foo] One.createElement(~test=true, ~foo=2, ~children=["a", "b"],());
let asd2 = [@JSX] [@foo] One.createElementobvioustypo(~test=false, ~children=["a", "b"],());
let span(~test : bool,~foo : int,~children,()) = 1;
let asd = [@JSX] [@foo] span(~test=true, ~foo=2, ~children=["a", "b"],());
/* "video" call doesn't end with a list, so the expression isn't converted to JSX */
let video(~test: bool,children) = children;
let asd2 = [@JSX] [@foo] video(~test=false,10);
let div(~children) = 1;
([@JSX] (((fun () => div) ())(~children=[])));
let myFun () {
<>
<Namespace.Foo intended=(true) anotherOptional=200 />
<Namespace.Foo intended=(true) anotherOptional=200 />
<Namespace.Foo intended=(true) anotherOptional=200>
<Foo />
<Foo />
<Foo />
<Foo />
<Foo />
<Foo />
<Foo />
</Namespace.Foo>
</>;
};
let myFun () {
<>
</>;
};
let myFun () {
<>
<Namespace.Foo intended=(true) anotherOptional=200 />
<Namespace.Foo intended=(true) anotherOptional=200 />
<Namespace.Foo intended=(true) anotherOptional=200>
<Foo />
<Foo />
<Foo />
<Foo />
<Foo />
<Foo />
<Foo />
</Namespace.Foo>
</>;
};
/**
* Children should wrap without forcing attributes to.
*/
<Foo a=10 b=0>
<Bar />
<Bar />
<Bar />
<Bar />
</Foo>;
/**
* Failing test cases:
*/
/* let res = <Foo a=10 b=(<Foo a=200 />) > */
/* <Bar /> */
/* </Foo>; */
/* let res = <Foo a=10 b=(<Foo a=200 />) />; */
let zzz = Some("oh hai");
/* this should be the only test that generates a warning. We're explicitly testing for this */
let optionalCallSite = <Optional1 required=?zzz />;
fakeRender(optionalCallSite);
let optionalArgument = <Optional2 />;
fakeRender(optionalArgument);
let optionalArgument = <Optional2 optional=?zzz />;
fakeRender(optionalArgument);
let defaultArg = <DefaultArg />;
fakeRender(defaultArg);
let defaultArg = <DefaultArg default=zzz />;
fakeRender(defaultArg);
([@JSX][@bla] NotReallyJSX.createElement([],~foo=1,~bar=2));
([@bla][@JSX] NotReallyJSX.createElement(~foo=1,[],~bar=2));
([@JSX][@bla] notReallyJSX([],~foo=1));
([@bla][@JSX] notReallyJSX(~foo=1,[],~bar=2));
/* children can be at any position */
([@JSX] span(~children=[],~test=true,~foo=2,()));
([@JSX] Optional1.createElement(~children=[],~required=Some("hi"),()));
/* preserve some other attributes too! */
([@JSX][@bla] span(~children=[],~test=true,~foo=2,()));
([@bla][@JSX] span(~children=[],~test=true,~foo=2,()));
([@JSX][@bla] Optional1.createElement(~children=[],~required=Some("hi"),()));
([@bla][@JSX] Optional1.createElement(~children=[],~required=Some("hi"),()));
/* Overeager JSX punning #1099 */
module Metal = {
let fiber = "fiber";
};
module OverEager = {
let createElement(~fiber,~children,()) {displayName: "test"};
};
let element = <OverEager fiber=Metal.fiber />;
type style = {
width: int,
height: int,
paddingTop: int,
paddingLeft: int,
paddingRight: int,
paddingBottom: int
};
module Window = {
let createElement(~style,~children,()) {displayName: "window"};
};
let w =
<Window
style={
width: 10,
height: 10,
paddingTop: 10,
paddingLeft: 10,
paddingRight: 10,
paddingBottom: 10
}
/>;
let foo = None;
let g = <Two ?foo />;
/* https://github.com/facebook/reason/issues/1428 */
<Foo> ...element </Foo>;
<Foo> ...((a) => 1) </Foo>;
<Foo> ...<Foo2 /> </Foo>;
<Foo> ...[|a|] </Foo>;
<Foo> ...(1, 2) </Foo>;
module Foo3 = {
let createElement = (~bar, ~children, ()) => ();
};
<Foo3 bar=<Foo /> />;
let onClickHandler = () => ();
let div = (~onClick, ~children, ()) => ();
<div onClick=onClickHandler> <> "foobar" </> </div>;
/*
* This is identical to just having "foobar" as a single JSX child (which means
* it's in a list).
*/
let yetAnotherDiv = <div onClick=onClickHandler>... <> "foobar" </> </div>;
let tl = [];
/*
* Spreading a list that has an identifier/expression as its tail. This should
* preserve the spread and preserve the braces. [list] is not considered
* simple for the purposes of spreading into JSX, or as a child.
*/
<div onClick=onClickHandler>...{[yetAnotherDiv, ...tl]}</div>;
/*
* This is equivalent to having no children.
*/
<div onClick=onClickHandler>...{[]}</div>;
================================================
FILE: test/4.12/type-jsx.t/run.t
================================================
Format basic
$ refmt --print re ./input.re > ./formatted.re
Print the formatted file
$ cat ./formatted.re
type component = {displayName: string};
module Bar = {
let createElement = (~c=?, ~children, ()) => {
displayName: "test",
};
};
module Nesting = {
let createElement = (~children, ()) => {
displayName: "test",
};
};
module Much = {
let createElement = (~children, ()) => {
displayName: "test",
};
};
module Foo = {
let createElement =
(~a=?, ~b=?, ~children, ()) => {
displayName: "test",
};
};
module One = {
let createElement =
(~test=?, ~foo=?, ~children, ()) => {
displayName: "test",
};
let createElementobvioustypo =
(~test, ~children, ()) => {
displayName: "test",
};
};
module Two = {
let createElement = (~foo=?, ~children, ()) => {
displayName: "test",
};
};
module Sibling = {
let createElement =
(~foo=?, ~children: list(component), ()) => {
displayName: "test",
};
};
module Test = {
let createElement = (~yo=?, ~children, ()) => {
displayName: "test",
};
};
module So = {
let createElement = (~children, ()) => {
displayName: "test",
};
};
module Foo2 = {
let createElement = (~children, ()) => {
displayName: "test",
};
};
module Text = {
let createElement = (~children, ()) => {
displayName: "test",
};
};
module Exp = {
let createElement = (~children, ()) => {
displayName: "test",
};
};
module Pun = {
let createElement =
(~intended=?, ~children, ()) => {
displayName: "test",
};
};
module Namespace = {
module Foo = {
let createElement =
(
~intended=?,
~anotherOptional as x=100,
~children,
(),
) => {
displayName: "test",
};
};
};
module Optional1 = {
let createElement = (~required, ~children, ()) => {
switch (required) {
| Some(a) => { displayName: a }
| None => { displayName: "nope" }
};
};
};
module Optional2 = {
let createElement =
(~optional=?, ~children, ()) => {
switch (optional) {
| Some(a) => { displayName: a }
| None => { displayName: "nope" }
};
};
};
module DefaultArg = {
let createElement =
(~default=Some("foo"), ~children, ()) => {
switch (default) {
| Some(a) => { displayName: a }
| None => { displayName: "nope" }
};
};
};
module LotsOfArguments = {
let createElement =
(
~argument1=?,
~argument2=?,
~argument3=?,
~argument4=?,
~argument5=?,
~argument6=?,
~children,
(),
) => {
displayName: "test",
};
};
let div = (~argument1=?, ~children, ()) => {
displayName: "test",
};
module List1 = {
let createElement = (~children, ()) => {
displayName: "test",
};
};
module List2 = {
let createElement = (~children, ()) => {
displayName: "test",
};
};
module List3 = {
let createElement = (~children, ()) => {
displayName: "test",
};
};
module NotReallyJSX = {
let createElement = (~foo, ~bar, children) => {
displayName: "test",
};
};
let notReallyJSX = (~foo, ~bar, children) => {
displayName: "test",
};
let fakeRender = (el: component) => {
el.displayName;
};
/* end of setup */
let (/><) = (a, b) => a + b;
let (><) = (a, b) => a + b;
let (/>) = (a, b) => a + b;
let (></) = (a, b) => a + b;
let tag1 = 5 />< 6;
let tag2 = 5 >< 7;
let tag3 = 5 /> 7;
let tag4 = 5 ></ 7;
let b = 2;
let selfClosing = <Foo />;
let selfClosing2 = <Foo a=1 b=true />;
let selfClosing3 =
<Foo
a="really long values that should"
b="cause the entire thing to wrap"
/>;
let a = <Foo> <Bar c={a => a + 2} /> </Foo>;
let a3 = <So> <Much> <Nesting /> </Much> </So>;
let a4 =
<Sibling>
<One test=true foo=b />
<Two foo=b />
</Sibling>;
let a5 = <Foo> "testing a string here" </Foo>;
let a6 =
<Foo2>
<Text> "testing a string here" </Text>
<Test yo=1 />
<Text> "another string" </Text>
<Bar />
<Exp> {2 + 4} </Exp>
</Foo2>;
let intended = true;
let punning = <Pun intended />;
let namespace = <Namespace.Foo />;
let c = <Foo />;
let d = <Foo />;
let spaceBefore =
<So> <Much> <Nesting /> </Much> </So>;
let spaceBefore2 = <So> <Much /> </So>;
let siblingNotSpaced =
<So> <Much /> <Much /> </So>;
let jsxInList = [<Foo />];
let jsxInList2 = [<Foo />];
let jsxInListA = [<Foo />];
let jsxInListB = [<Foo />];
let jsxInListC = [<Foo />];
let jsxInListD = [<Foo />];
let jsxInList3 = [<Foo />, <Foo />, <Foo />];
let jsxInList4 = [<Foo />, <Foo />, <Foo />];
let jsxInList5 = [<Foo />, <Foo />];
let jsxInList6 = [<Foo />, <Foo />];
let jsxInList7 = [<Foo />, <Foo />];
let jsxInList8 = [<Foo />, <Foo />];
let testFunc = b => b;
let jsxInFnCall = testFunc(<Foo />);
let lotsOfArguments =
<LotsOfArguments
argument1=1
argument2=2
argument3=3
argument4=4
argument5=5
argument6="test">
<Namespace.Foo />
</LotsOfArguments>;
let lowerCase = <div argument1=1 />;
let b = 0;
let d = 0;
/*
* Should pun the first example:
*/
let a = <Foo a> 5 </Foo>;
let a = <Foo a=b> 5 </Foo>;
let a = <Foo a=b b=d> 5 </Foo>;
let a = <Foo a> 0.55 </Foo>;
let a = <Foo />;
let ident = <Foo> a </Foo>;
let fragment1 = <> <Foo /> <Foo /> </>;
let fragment2 = <> <Foo /> <Foo /> </>;
let fragment3 = <> <Foo /> <Foo /> </>;
let fragment4 = <> <Foo /> <Foo /> </>;
let fragment5 = <> <Foo /> <Foo /> </>;
let fragment6 = <> <Foo /> <Foo /> </>;
let fragment7 = <> <Foo /> <Foo /> </>;
let fragment8 = <> <Foo /> <Foo /> </>;
let fragment9 = <> 2 2 2 2 </>;
let fragment10 = <> 2.2 3.2 4.6 1.2 </>;
let fragment11 = <> "str" </>;
let fragment12 = <> {6 + 2} {6 + 2} {6 + 2} </>;
let fragment13 = <> fragment11 fragment11 </>;
let listOfItems1 = <List1> 1 2 3 4 5 </List1>;
let listOfItems2 =
<List2> 1.0 2.8 3.8 4.0 5.1 </List2>;
let listOfItems3 =
<List3> fragment11 fragment11 </List3>;
/*
* Several sequential simple jsx expressions must be separated with a space.
*/
let thisIsRight = (a, b) => ();
let tagOne = (~children, ()) => ();
let tagTwo = (~children, ()) => ();
/* thisIsWrong <tagOne /><tagTwo />; */
thisIsRight(<tagOne />, <tagTwo />);
/* thisIsWrong <tagOne> </tagOne><tagTwo> </tagTwo>; */
thisIsRight(<tagOne />, <tagTwo />);
let a = (~children, ()) => ();
let b = (~children, ()) => ();
let thisIsOkay =
<List1> <a /> <b /> <a /> <b /> </List1>;
let thisIsAlsoOkay =
<List1> <a /> <b /> </List1>;
/* Doesn't make any sense, but suppose you defined an
infix operator to compare jsx */
<a /> < <b />;
<a /> > <b />;
<a /> < <b />;
<a /> > <b />;
let listOfListOfJsx = [<> </>];
let listOfListOfJsx = [<> <Foo /> </>];
let listOfListOfJsx = [
<> <Foo /> </>,
<> <Bar /> </>,
];
let listOfListOfJsx = [
<> <Foo /> </>,
<> <Bar /> </>,
...listOfListOfJsx,
];
let sameButWithSpaces = [<> </>];
let sameButWithSpaces = [<> <Foo /> </>];
let sameButWithSpaces = [
<> <Foo /> </>,
<> <Bar /> </>,
];
let sameButWithSpaces = [
<> <Foo /> </>,
<> <Bar /> </>,
...sameButWithSpaces,
];
/*
* Test named tag right next to an open bracket.
*/
let listOfJsx = [];
let listOfJsx = [<Foo />];
let listOfJsx = [<Foo />, <Bar />];
let listOfJsx = [
<Foo />,
<Bar />,
...listOfJsx,
];
let sameButWithSpaces = [];
let sameButWithSpaces = [<Foo />];
let sameButWithSpaces = [<Foo />, <Bar />];
let sameButWithSpaces = [
<Foo />,
<Bar />,
...sameButWithSpaces,
];
/**
* Test no conflict with polymorphic variant types.
*/
type thisType = [
| `Foo
| `Bar
];
type t('a) = [< thisType] as 'a;
let asd =
[@foo] <One test=true foo=2> "a" "b" </One>;
let asd2 =
[@foo]
<One.createElementobvioustypo test=false>
"a"
"b"
</One.createElementobvioustypo>;
let span =
(~test: bool, ~foo: int, ~children, ()) => 1;
let asd =
[@foo] <span test=true foo=2> "a" "b" </span>;
/* "video" call doesn't end with a list, so the expression isn't converted to JSX */
let video = (~test: bool, children) => children;
let asd2 = [@foo] [@JSX] video(~test=false, 10);
let div = (~children) => 1;
[@JSX] ((() => div)())(~children=[]);
let myFun = () => {
<>
<Namespace.Foo
intended=true
anotherOptional=200
/>
<Namespace.Foo
intended=true
anotherOptional=200
/>
<Namespace.Foo
intended=true anotherOptional=200>
<Foo />
<Foo />
<Foo />
<Foo />
<Foo />
<Foo />
<Foo />
</Namespace.Foo>
</>;
};
let myFun = () => {
<> </>;
};
let myFun = () => {
<>
<Namespace.Foo
intended=true
anotherOptional=200
/>
<Namespace.Foo
intended=true
anotherOptional=200
/>
<Namespace.Foo
intended=true anotherOptional=200>
<Foo />
<Foo />
<Foo />
<Foo />
<Foo />
<Foo />
<Foo />
</Namespace.Foo>
</>;
};
/**
* Children should wrap without forcing attributes to.
*/
<Foo a=10 b=0>
<Bar />
<Bar />
<Bar />
<Bar />
</Foo>;
/**
* Failing test cases:
*/
/* let res = <Foo a=10 b=(<Foo a=200 />) > */
/* <Bar /> */
/* </Foo>; */
/* let res = <Foo a=10 b=(<Foo a=200 />) />; */
let zzz = Some("oh hai");
/* this should be the only test that generates a warning. We're explicitly testing for this */
let optionalCallSite =
<Optional1 required=?zzz />;
fakeRender(optionalCallSite);
let optionalArgument = <Optional2 />;
fakeRender(optionalArgument);
let optionalArgument =
<Optional2 optional=?zzz />;
fakeRender(optionalArgument);
let defaultArg = <DefaultArg />;
fakeRender(defaultArg);
let defaultArg = <DefaultArg default=zzz />;
fakeRender(defaultArg);
([@bla]
[@JSX]
NotReallyJSX.createElement([], ~foo=1, ~bar=2));
([@bla]
[@JSX]
NotReallyJSX.createElement(~foo=1, [], ~bar=2));
([@bla] [@JSX] notReallyJSX([], ~foo=1));
([@bla] [@JSX] notReallyJSX(~foo=1, [], ~bar=2));
/* children can be at any position */
<span test=true foo=2 />;
<Optional1 required={Some("hi")} />;
/* preserve some other attributes too! */
([@bla] <span test=true foo=2 />);
([@bla] <span test=true foo=2 />);
([@bla] <Optional1 required={Some("hi")} />);
([@bla] <Optional1 required={Some("hi")} />);
/* Overeager JSX punning #1099 */
module Metal = {
let fiber = "fiber";
};
module OverEager = {
let createElement = (~fiber, ~children, ()) => {
displayName: "test",
};
};
let element = <OverEager fiber=Metal.fiber />;
type style = {
width: int,
height: int,
paddingTop: int,
paddingLeft: int,
paddingRight: int,
paddingBottom: int,
};
module Window = {
let createElement = (~style, ~children, ()) => {
displayName: "window",
};
};
let w =
<Window
style={
width: 10,
height: 10,
paddingTop: 10,
paddingLeft: 10,
paddingRight: 10,
paddingBottom: 10,
}
/>;
let foo = None;
let g = <Two ?foo />;
/* https://github.com/facebook/reason/issues/1428 */
<Foo> ...element </Foo>;
<Foo> ...{a => 1} </Foo>;
<Foo> ...<Foo2 /> </Foo>;
<Foo> ...[|a|] </Foo>;
<Foo> ...(1, 2) </Foo>;
module Foo3 = {
let createElement = (~bar, ~children, ()) =>
();
};
<Foo3 bar={<Foo />} />;
let onClickHandler = () => ();
let div = (~onClick, ~children, ()) => ();
<div onClick=onClickHandler>
<> "foobar" </>
</div>;
/*
* This is identical to just having "foobar" as a single JSX child (which means
* it's in a list).
*/
let yetAnotherDiv =
<div onClick=onClickHandler> "foobar" </div>;
let tl = [];
/*
* Spreading a list that has an identifier/expression as its tail. This should
* preserve the spread and preserve the braces. [list] is not considered
* simple for the purposes of spreading into JSX, or as a child.
*/
<div onClick=onClickHandler>
...{[yetAnotherDiv, ...tl]}
</div>;
/*
* This is equivalent to having no children.
*/
<div onClick=onClickHandler />;
Type-check basics
$ ocamlc -c -pp 'refmt --print binary' -intf-suffix .rei -impl formatted.re
File "formatted.re", line 463, characters 23-26:
463 | <Optional1 required=?zzz />;
^^^
Warning 43 [nonoptional-label]: the label required is not optional.
Format the formatted file back
$ refmt --print re ./formatted.re > ./formatted_back.re
Ensure idempotency: first format and second format are the same
$ diff formatted.re formatted_back.re
================================================
FILE: test/4.12/typecheck-let-ops.t
================================================
$ cat > input.ml <<EOF
> open struct
> type t = string
> end
>
> let (let+) x f = List.map f x
>
> let (and+) = List.map2 (fun x y -> x,y)
>
> let x =
> let+ x = [2]
> and+ y = [3]
> in
> x, y
>
> let y =
> let+ x = [2] in
> x
> EOF
Format basic
$ refmt --print re ./input.ml > ./formatted.re
Type-check basics
$ ocamlc -c -pp 'refmt --print binary' -intf-suffix .rei -impl formatted.re
Format the formatted file back
$ refmt --print re ./formatted.re > ./formatted_back.re
Ensure idempotency: first format and second format are the same
$ diff formatted.re formatted_back.re
================================================
FILE: test/README.md
================================================
# refmt cram test suite
This folder contains dune's cram tests.
More information on how they work and how to create them in [dune's documentation](https://dune.readthedocs.io/en/stable/tests.html#cram-tests).
## Run them locally use
```bash
esy dune runtest
# or in watch mode
esy dune runtest -w
```
## Update snapshot
The usual workflow is to run the test once, let it fail and then update the snapshot with the output you expect with promotion:
```bash
esy dune promote
```
## Run only one test
```bash
esy dune build @cram-test-name
# for example: esy dune build @assert
```
## Update only one snapshot
```bash
esy dune build @cram-test-name --auto-promote
# for example: esy dune build @assert
```
## Testing a specific version of OCaml
Some tests are specifically designed to test a specific version of OCaml. To run them, you have a few options:
### Install an specific OCaml version with esy
Make sure the OCaml's version is between the range of the `ocaml` field in esy.json (`>= 4.2.0 < 4.15.0`).
1. Install the specific version you want with: `esy add ocaml@{{ ocaml_version }}`
2. Run the test with: `esy dune runtest`
### Setup the local environment with opam
The opam workflow is only tested in CI and isn't needed for development, but can become handy since you can install many switches with different versions of OCaml and load them when needed.
Using 4.12 as an example:
1. Create the switch: `opam switch create reason-dev-4.12 -y --deps-only --with-test 4.12.0`
2. Install dependencies (this only needs to be done once) `opam install . --deps-only --with-test`
3. Load env variables for your switch `eval $(opam env --switch=reason-dev-4.12 --set-switch)`
4. Run the test with: `opam exec -- dune runtest`
================================================
FILE: test/arityConversion.t/arity.txt
================================================
And
TupleConstructor
Or
M.TupleConstructorInModule
TupleConstructor2
.TupleConstructor3
M.TupleConstructor3
================================================
FILE: test/arityConversion.t/input.ml
================================================
Some (1, 2, 3)
type bcd = TupleConstructor of (int * int) | MultiArgumentsConstructor of int * int
let a = TupleConstructor(1, 2)
let b = MultiArgumentsConstructor(1, 2)
module Test = struct
type a = | And of (int * int) | Or of (int * int)
end;;
let _ = Test.And (1, 2)
let _ = Test.Or (1, 2)
let _ = Some 1;;
Test.And (1, 2);;
Test.Or (1, 2);;
Some 1;;
module M = struct
type t = TupleConstructorInModule of (int * int)
type t2 = TupleConstructor2 of (int * int)
type t3 = TupleConstructor3 of (int * int)
end
type t2 = TupleConstructor2 of (int * int)
type t3 = TupleConstructor3 of (int * int)
let _ = M.TupleConstructorInModule (1,2)
let _ = M.TupleConstructor2 (1,2)
let _ = TupleConstructor2 (1,2)
let _ = M.TupleConstructor3 (1,2)
let _ = TupleConstructor3 (1,2);;
M.TupleConstructorInModule (1,2);;
M.TupleConstructor2 (1,2);;
TupleConstructor2 (1,2);;
M.TupleConstructor3 (1,2);;
TupleConstructor3 (1,2);;
================================================
FILE: test/arityConversion.t/run.t
================================================
Format basic
$ refmt --heuristics-file ./arity.txt --print re ./input.ml > ./formatted.re
Type-check basics
$ ocamlc -c -pp 'refmt --print binary' -intf-suffix .rei -impl formatted.re
Format the formatted file back
$ refmt --print re ./formatted.re > ./formatted_back.re
Ensure idempotency: first format and second format are the same
$ diff formatted.re formatted_back.re
================================================
FILE: test/assert.t/input.re
================================================
switch(true) {
| true => ()
| false => assert(false)
| _ => assert false
};
let root = {
let root = Doc.rootNode(doc);
assert (root.type_ == "expression");
assert (Node.namedChildCount(root) == 1);
assert (Node.childCount(root) == 1);
assert (Point.toString(root.startPoint) == "(Point.t {:row 0 :column 0})");
assert (Point.toString(root.endPoint) == "(Point.t {:row 0 :column 9})");
root;
};
assert(theTruth());
================================================
FILE: test/assert.t/run.t
================================================
Format assertions
$ refmt ./input.re
switch (true) {
| true => ()
| false => assert(false)
| _ => assert(false)
};
let root = {
let root = Doc.rootNode(doc);
assert(root.type_ == "expression");
assert(Node.namedChildCount(root) == 1);
assert(Node.childCount(root) == 1);
assert(
Point.toString(root.startPoint)
== "(Point.t {:row 0 :column 0})",
);
assert(
Point.toString(root.endPoint)
== "(Point.t {:row 0 :column 9})",
);
root;
};
assert(theTruth());
================================================
FILE: test/attributes-rei.t/input.rei
================================================
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
[@ocaml.text "Floating comment text should be removed"];
let test : int;
/**
* Attributes with doc/text attributes should be stripped. They're left over from a
* conversion from ML likely.
* ----------------------
*/
[@ocaml.doc "Floating doc text should be removed"];
/**
* #990: don't strip attributes in interface files
*/
[@bs.val]
let x: int;
type t('a);
type reactClass;
type reactElement;
[@bs.val] [@bs.module "React"]
external createClassInternalHack : (t('classSpec)) => reactClass = "createClass";
[@bs.send.pipe : array('a)] external map: [@bs] (('a) => 'b) => array('b) = "";
[@bs.send.pipe : array('a)] external map: [@bs] (('a) => 'b) => array('b);
[@bs.val] [@bs.module "react"]
external createClassInternalHack : (t('classSpec)) => reactClass =
"createClass";
[@bs.val] [@bs.module "react"] [@bs.splice]
external createCompositeElementInternalHack :
(reactClass, t({.. reasonProps : 'props}), array(reactElement)) => reactElement =
"createElement";
/* Record item attributes */
type t_ = {
/** Comment attribute on record item */
x: int
};
type tt = {
[@attr "on record field"]
x: int
};
type ttt = {
[@attr "on record field"]
x: [@attr "on type itself"] int
};
type tttt = {
/** Comment attribute on record item */
x: int,
[@regularAttribute "on next item"]
y: int
};
type ttttt = [@attr "moved to first row"] {
[@attr]
x: int
};
module Foo: { [@someattr] let foo: int => int; };
================================================
FILE: test/attributes-rei.t/run.t
================================================
Format basic
$ refmt --print re ./input.rei > ./formatted.rei
Type-check basics
$ ocamlc -c -pp 'refmt --print binary' -intf formatted.rei
Format the formatted file back
$ refmt --print re ./formatted.rei > ./formatted_back.rei
Ensure idempotency: first format and second format are the same
$ diff formatted.rei formatted_back.rei
================================================
FILE: test/backportSyntax.t/input.re
================================================
let (let.opt) = (x, f) => switch x { | None => None | Some(x) => f(x) };
let (let.&opt) = (x, f) => switch x { | None => None | Some(x) => Some(f(x)) };
let (and.opt) = (a, b) => switch (a, b) { | (Some(a), Some(b)) => Some((a, b)) | _ => None };
let x = {
let.opt a = Some(1);
let.opt b = Some(2)
and.opt c = Some(3)
and.opt d = Some(4);
Some((a, b, c, d))
}
let y = {
let.opt a = Some(1)
and.opt b = None
and.opt c = Some(4);
Some((a, b, c))
}
assert(x == Some((1,2,3,4)));
assert(y == None);
print_endline("Success")
================================================
FILE: test/backportSyntax.t/run.t
================================================
$ refmt ./input.re --print binary > ./output.bin
$ ocamlc -impl ./output.bin -o ./out
$ ./out
Success
================================================
FILE: test/basic.t/input.re
================================================
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
let x1 = () => 1;
let x2 = (a) => 1;
let x3 = (a: int, b) => 1;
let x4 = ((a,b)) => 1;
let x5 = fun (a,b): int => 1;
let x6 = (~x, ~y) => 1;
let x7 = (~x: int, ~y: string) => 1;
let x8 = (~x=5, ~y=?, ~z: option(string)=?, ()) => 1;
type a = int;
type b = float;
type c = string;
type t1 = (a) => b;
type t2 = (a, b) => c;
type t3 = ((a, b)) => c;
type t4 = (~x: int, ~y: string) => c;
type t5 = (~x: a=?) => b;
type tf = (int => int) => string;
type tNested2 = ((int => int)) => string;
type tNested3 = ((int => int) => int) => string;
type tNested4 = (int, int) => string;
type tNested5 = ((int, int)) => string;
type t6 = int;
type t7('a) = list('a);
type t8('a, 'b) = (list('a), 'b);
type t9 = t8(string, int);
class type restricted_point_type = {
pub get_x: int;
pub bump: unit;
};
class type t10('a) = {
pub thing: 'a;
};
class type t11('a, 'b) = {
pub thing: ('a, list('b))
};
module MyFirstModule = {
let x = 0;
type i = int
and n = string;
};
module type HasTT = {
type tt;
};
module SubModule: HasTT = {
type tt = int;
};
module type HasEmbeddedHasTT = {
module SubModuleThatHasTT = SubModule;
};
module type HasPolyType = {type t('a);};
module type HasDoublePoly = {type m('b, 'c);};
module type HasDestructivelySubstitutedPolyType =
HasPolyType with type t('a) := list('a);
module type HasDestructivelySubstitutedSubPolyModule = {
/* Cannot perform destructive substitution on submodules! */
/* module X: HasPolyType with type t := list (int, int); */
module X: HasDestructivelySubstitutedPolyType;
};
module type HasSubPolyModule = {
/* Cannot perform destructive substitution on submodules! */
/* module X: HasPolyType with type t := list (int, int); */
module X: HasPolyType;
};
module EmbedsSubPolyModule: HasSubPolyModule = {
module X = {
type t('a) = list('a);
};
};
module InliningSig: {let x: int; let y:int;} = {
let x = 10;
let y = 20;
};
module MyFunctor = fun (M: HasTT) => {
type reexportedTT = M.tt;
let someValue = 1000;
};
module MyFunctorResult = MyFunctor ({type tt = string;});
module type ASig = {let a:int;};
module type BSig = {let b:int;};
module CurriedSugar (A:ASig, B:BSig) {
let result = A.a + B.b;
};
type withThreeFields = {
name: string,
age: int,
occupation: string
};
let testRecord = {
name: "joe",
age: 20,
occupation: "engineer"
};
let makeRecordBase () {name: "Joe", age: 30, occupation: "Engineer"};
type t =
| A
| B(int)
| C(int, int)
| D((int, int));
type foo = {x:int};
let result = Some {x:1};
type tt1 = A(int) | B(bool, string);
type tt2 = A(int) | B((bool, string));
type tt3 = [ `A(int) | `B(bool, string) | `C];
type tt4 = [ `A(int) | `B((bool, string)) | `C];
let (==) = 0;
let (===) = 0;
let (!=) = 0;
let (!==) = 0;
type foobar(_) = | Foo('a): foobar(unit);
================================================
FILE: test/basic.t/run.t
================================================
See the typed tree from ./input.re
$ cat ./input.re | ../lib/outcometreePrinter.exe
let x1: unit => int;
let x2: 'a => int;
let x3: (int, 'a) => int;
let x4: (('a, 'b)) => int;
let x5: ('a, 'b) => int;
let x6: (~x: 'a, ~y: 'b) => int;
let x7: (~x: int, ~y: string) => int;
let x8: (~x: int=?, ~y: 'a=?, ~z: string=?, unit) => int;
type a = int;
type b = float;
type c = string;
type t1 = a => b;
type t2 = (a, b) => c;
type t3 = ((a, b)) => c;
type t4 = (~x: int, ~y: string) => c;
type t5 = (~x: a=?) => b;
type tf = (int => int) => string;
type tNested2 = (int => int) => string;
type tNested3 = ((int => int) => int) => string;
type tNested4 = (int, int) => string;
type tNested5 = ((int, int)) => string;
type t6 = int;
type t7('a) = list('a);
type t8('a, 'b) = (list('a), 'b);
type t9 = t8(string, int);
class type restricted_point_type = { pub bump: unit; pub get_x: int };
class type t10 ('a) = { pub thing: 'a };
class type t11 ('a, 'b) = { pub thing: ('a, list('b)) };
module MyFirstModule: { let x: int; type i = int and n = string; };
module type HasTT = { type tt; };
module SubModule: HasTT;
module type HasEmbeddedHasTT = { module SubModuleThatHasTT = SubModule; };
module type HasPolyType = { type t('a); };
module type HasDoublePoly = { type m('b, 'c); };
module type HasDestructivelySubstitutedPolyType = { };
module type HasDestructivelySubstitutedSubPolyModule =
{ module X: HasDestructivelySubstitutedPolyType; };
module type HasSubPolyModule = { module X: HasPolyType; };
module EmbedsSubPolyModule: HasSubPolyModule;
module InliningSig: { let x: int; let y: int; };
module MyFunctor:
(M : HasTT) => { type reexportedTT = M.tt; let someValue: int; };
module MyFunctorResult: { type reexportedTT = string; let someValue: int; };
module type ASig = { let a: int; };
module type BSig = { let b: int; };
module CurriedSugar: (A : ASig) => (B : BSig) => { let result: int; };
type withThreeFields = { name: string, age: int, occupation: string, };
let testRecord: withThreeFields;
let makeRecordBase: unit => withThreeFields;
type t = A | B(int) | C(int, int) | D((int, int));
type foo = { x: int, };
let result: option(foo);
type tt1 = A(int) | B(bool, string);
type tt2 = A(int) | B((bool, string));
type tt3 = [ `A(int) | `B(bool, string) | `C ];
type tt4 = [ `A(int) | `B(bool, string) | `C ];
let ( == ): int;
let ( === ): int;
let ( != ): int;
let ( !== ): int;
type foobar(_) = Foo('a): foobar(unit);
================================================
FILE: test/basicStructures.t/input.re
================================================
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
let run = fun () => {TestUtils.printSection("Basic Structures");};
while (something) {
print_string ("You're in a while loop");
print_newline ();
};
for (i in 0 to 5) {
print_int (i);
print_newline ();
for (i in 10 downto 0) {
print_string ("Counting in reverse direction");
print_newline ();
};
};
for (i in 0 to endOfRangeMustBeSimple(expr,soWrap)) {
print_int (i);
print_newline ();
for (i in theSame(isTrue,ofThe,startOfRange) downto 0) {
print_string ("Counting in reverse direction");
print_newline ();
};
};
let x = (foo^)^.bar^;
let x = foo.bar^;
let x = foo#bar^;
let x = foo^.bar^;
let x = (foo^)#bar^;
/* Prefix operators:
* ! followed by zero or more appropriate_operator_suffix_chars (see the
* lexer).
* ? or ~ followed by at least one appropriate_operator_suffix_chars.
*/
let x = !(! !foo).bar;
let x = !foo.bar;
let x = !foo#bar;
let x = !(!foo).bar;
let x = !(!foo)#bar;
let x = ! !foo.bar;
let x = ?! (!foo.bar);
let x = ! ?!foo.bar;
let x = ~! (!foo.bar);
let x = ! ~!foo.bar;
let x = ~! ~!foo.bar;
let x = !!foo.bar;
let x = !!foo#bar;
let x = !~foo.bar;
let x = !~foo#bar;
let noParensNeeded = !blah.foo.bar;
let parensNeededAroundFirst = (!blah).foo.bar;
let parensNeededAroundSecond = (!blah.foo).bar;
let noParensNeeded = !blah#foo#bar;
let parensNeededAroundFirst = (!blah)#foo#bar;
let parensNeededAroundSecond = (!blah#foo)#bar;
let parensWithSpaceNeededAroundFirst = (! !blah)#foo#bar;
let parensWithSpaceNeededAroundSecond = (! !blah#foo)#bar;
let parensWithSpaceNeededAroundFirst = (?! ~+blah)#foo#bar;
let parensWithSpaceNeededAroundSecond = (?! ~+blah#foo)#bar;
let x = !(!foo.bar);
let x = !(!foo#bar);
let x = -10;
let x = -5.0;
let x = Some(-10);
let x = Some(-5.0);
let lazy x = 10;
let lazy (x : int) = 10;
let lazy [] = 10;
let lazy true = 10;
let lazy #x = 10;
let lazy `Variant = 10;
let lazy `variant = 10;
let lazy ('0' .. '9') = 10;
let lazy (lazy true) = 10;
let lazy [%extend] = 10;
/* Test precedence on access sugar */
let x = arr^[0];
let x = Array.get(arr^,0);
let x = str^.[0];
let x = String.get(str^,0);
let x = Array.set(arr^,0,1);
let x = arr^[0] = 1;
/* Comments */
/*Below is an empty comment*/
/**/
/** IF
*============================================================================
*/;
let (/++) = (+); /* // indicates the start of a comment, not an infix op */
let something = if (self.ext.logSuccess) {
print_string("Did tap");
print_newline ();
};
let logTapSuccess = fun(self) => if (self.ext.logSuccess) {
print_string("Did tap");
print_newline ();
} else {
();
};
let logTapSuccess(self) = if (self.ext.logSuccess) {
print_string("Did tap");
print_newline ();
};
(!data).field = true;
(!data).field1.field2 = true;
(!data.field1).field2 = true;
((!data).field1).field2 = true;
(!(data.field1)).field2 = true;
let loop(appTime,frameTime) = {
if (hasSetup.contents) {
setupScene ();
renderIntoTop ();
hasSetup.contents = true;
};
process(appTime,frameTime);
};
/* These parens should be kept around the entire last if/then/else */
if (something) {
if (somethingElse) {
();
} else {
"blah";
};
};
/* These parens should be kept around just the last if/then*/
if (something) {if (somethingElse) {();} else {"blah";};};
/* Parens should be generated to wrap the entire final if then else.
* To test that it's being parsed correclty, should print "one". */
if (true) {
if (true) {
print_string("one");
} else {
print_string("two");
};
};
/* Should print two */
if (true) {
if (false) {
print_string("one");
} else {
print_string("two");
};
};
/* Should not print */
if (false) {
if (true) {
print_string("one");
} else {
print_string("two");
};
};
/* Should wrap (if a > b then a else b).
* printer(
*/
let printIfFirstArgGreater = true;
let result =
if (printIfFirstArgGreater) {
fun(a,b) => if (a > b) {print_string("a > b");} else {print_string("b >= a");};
} else if ({
fun(a,b) => if (a > b) {print_string("b < a");} else {print_string("a <= b");};
}) {
print_string ("That could never possibly type check");
print_newline ();
};
let myRecord = {
nestedRecord: {
anotherNestedRecord: fun(instaComp,displayRect) =>
if (Graphics.cgRectIntersectsWithSlop
(defaultCompositeTimerRectSlop,instaComp.relativeRect,displayRect)) {
IoEligible;
} else {
IoInelibleButTryComposition;
}
}
};
if (printIfFirstArgGreater) {
fun(a,b) => if (a > b) {print_string("a > b");};
} else {fun(a,b) => if (a > b) {print_string("b < a");};};
/* Should Be Parsed As: Cleary a type error, but at least the parsing makes that clear */
if (printIfFirstArgGreater) {
fun(a,b) =>
if (a > b) {
print_string("a > b");
} else {
fun(a,b) => if (a > b) {print_string("b < a");};
};
};
fun(a,b) => if (a > b) {print_string("a > b");};
/* What you probably wanted was: */
if (printIfFirstArgGreater) {
fun(a,b) => (if (a > b) {print_string("a > b");});
} else {
fun(a,b) => (if (a > b) {print_string("b < a");});
};
/* Mutative if statement: Not used to evaluate to something. */
if (10 < 100) {
let msg = "If there was any doubt, 10 is in fact less than 100.";
print_string (msg);
} else {
let msg = "All bets are off.";
print_string (msg);
};
if (10 < 100) {
print_string ("If there was any doubt, 10 is in fact less than 100.");
} else {
print_string ("All bets are off.");
};
/** TYPE CONSTRAINTS
*============================================================================
*/;
let x = (10:int);
let x:int = 10;
let (x:int) = 10;
let (x:int) = (10:int);
/* let (x:int) = (10:string); */
/* let (x:string) = ("hello":int); */
/** TUPLES
*============================================================================
*/;
/* In Reason, types look like the data they model! Tuples are no exception. */
type pairOfInts = (int, int);
let (letBindingWithTypeConstraint:int) = 10;
let ((tupleItem:int), (withTypeConstraint:int)) = (10, 20);
/* To make sure that tuple field annotations are annotating the entire field */
let _dummyFunc(x) = 10;
let annotatingFuncApplication = (_dummyFunc("a"):int, _dummyFunc("a"):int);
/* Pretty printer might stick the [int] at the label. */
let annotatingSingleFuncApplication = (_dummyFunc("a"):int);
/* So lets try a place where it won't */
let annotatingSingleFuncApplication = {
/* Commenting a let binding. */
let a = 100;
/* Commenting another let binding. */
let int = 200;
/*
* This demonstrates why named arguments cannot simply have the form (func
* arg:val) - it is indistinguishable from a type constraint.
*/
2 + (_dummyFunc(a):int);
};
let (tupleItem:int, constrainedWithoutGrouping:int) = (10, 20);
let (tupleItem, withOutsideTypeConstraint):(int,int) = (10, 20);
/* Trailing commas */
let trailingCommaAccepted = (1, 2,);
let moreTrailing = (1, 2, 3, 4, 5, 7, );
/** Immutable Lists
* ============================================================================
*/;
/* Anatomy: -Head- --------- Tail--------- nil: You can't see nil */
let x: list(int) = [ 1, 2, 3, 4, 5, 6, 7, 8, 9];
let hd = "appendedToHead";
let tl = ["listTo", "append", "to"];
/* To push *one* and only *one* item to the front of a list - use [hd, ...tl] */
let result: list(string) = [hd, ...tl];
/* Is the same as writing */
let result: list(string) = ["appendedToHead", "listTo", "append", "to"];
/* To operate on lists, use pattern matching */
let rec size = fun
| [] => 0
| [hd, ...tl] => 1 + size(tl);
/* Optimize for tail recursion */
let rec size = fun(soFar,lst) => switch (lst) {
| [] => 0
| [hd, ...tl] => size(soFar + 1,tl)
};
let nestedMatch(lstLst) = switch (lstLst) {
| [hd, ...tl] when false => 10
| [hd, ...tl] => switch (tl) {
| [] => 0 + 0
| [tlHd, ...tlTl] => 0 + 1
}
| [] => 0
};
let nestedMatchWithWhen(lstLst) = switch (lstLst) {
| [hd, ...tl] when false => 10
| [hd, ...tl] when true => switch (tl) {
| [] when false => 0 + 0
| [] when true => 0 + 0
| [tlHd, ...tlTl] => 0 + 1
}
| [] => 0
};
/**
* Aliasing with "as" during matches.
*/;
type mine = MyThing(int) | YourThing(int);
/*
* Reason parses "as" aliases differently than OCaml.
*/
let ppp = switch (MyThing(20)) {
| MyThing(x) as ppp
| YourThing(x) as ppp => ppp
};
let MyThing(_) as ppp | YourThing(_) as ppp = ppp;
/*
* in order to achieve the previous example in ocaml, you would have to group
* as:
*/
let ppp = switch (MyThing(20)) {
| (MyThing(x) as ppp)
| (YourThing(x) as ppp) => ppp
};
let (MyThing(_) as ppp) |(YourThing(_) as ppp) = ppp;
/*
* But this isn't needed in Reason because OR patterns have much lower
* precedence - they should be pretty printed in the same way.
*/
/* TODO: */
/* let rec nestedMatch lstLst => match lstLst with { */
/* hd::tl: match tl with { */
/* []: 0 + 0, */
/* tlHd::tlTl: 0 + 1, */
/* }, */
/* []: 0 */
/* }; */
/* */
/** ARRAYS
* ============================================================================
* Arrays are weird looking. Usually you want lists because they support pattern
* matching - that's why they have nicer syntax - to entice you. But if you want
* random access and better control over memory layout, use arrays.
*/;
let emptyArray = [||];
let arrayWithOne = [|10|];
let arrayWithTwo = [|10, 10|];
let secondItem = Array.get(arrayWithTwo,1);
/* Getting And Setting: Yeah, we should really change this */
/* Get an array item at index 1 */
let secondItem = arrayWithTwo[1];
/* Set an array item at index 1 */
arrayWithTwo[1] = 300;
/**
* STRINGS
* ============================================================================
* The language supports mutating strings, but that should not be depended upon.
*/;
let myString = "asdf";
myString.[2] = '9'; /* Replacing a character: I could do without this sugar */
/* FUNCTIONS
*=============================================================================
*/
/* TYPE ANNOTATIONS
* =============================================================================
*/
let one = 900;
let two = 10000;
/* Tuple expressions can be annotated without additional paren wrapping */
let myTuple = (one:int, two:int);
type myTupleType = (int, int);
let myTuple = (myTuple:myTupleType);
/* Anything *outside* of a tuple, must still be annotated within parens. */
let myTuple = ((one:int, two:int):myTupleType);
/* Now functions that accept a single argument being a tuple look familiar */
let addValues = fun (a:int, b:int) => {
a + b;
};
let addValues = fun (a:int, b:int) => {
a + b;
};
let myFunction = fun (a : int, b : int) : int => a + b;
let functionReturnValueType (i:int, s:string): (int) => int = fun(x) => x + 1;
let curriedFormOne (i:int, s:string) = s ++ string_of_int(i);
let curriedFormTwo (i:int, x:int) :(int, int) = (i, x);
/* let nonCurriedFormTwo = fun (i:int, x:int) (:(int, int)) => (i, x); */
let curriedFormThree (i:int, (a:int, b:int):(int, int)) :(int, int, int) = (i, a, b);
/* let nonCurriedFormThree = fun (i:int, (a:int, b:int):(int, int)) (:(int, int, int)) => (i, a, b); */
/** TODO: But this, however doesn't work.
* let (myCurriedFunc: int => int) a => a;
* Note: This is likely because only "simple patterns" are accepted as constraints
* in let bindings - that may be easy to change.
*/;
type myFuncType = (int, int) => int;
let myFunc: myFuncType = fun (a,b) => a + b;
let funcWithTypeLocallyAbstractTypes (type atype, type btype, a, b, c: (atype, btype) => unit) = c(a,b);
/* Checks that function types aren't unnecessary wrapped */
type a = ((unit => unit));
type b =
| Foo((unit => unit))
| Bar((unit => unit), (unit => unit), ((a, b) => c))
| Baz(unit => unit, unit => unit, (a, b) => c);
type c =
| Foo((a, b) => unit)
| Bar(((a, b) => unit));
type d = [> | `Foo((unit => unit))];
/**
* Records:
*=============================================================================
*/;
type withThreeFields = {
name: string,
age: int,
occupation: string
};
let testRecord = {
name: "joe",
age: 20,
occupation: "engineer"
};
let anotherRecord = {
...testRecord,
name: "joe++",
age: testRecord.age + 10
};
let makeRecordBase () {name: "Joe", age: 30, occupation: "Engineer"};
let anotherRecord = {
/* These parens should be evaporated. */
...(makeRecordBase ()),
name: "joe++",
age: testRecord.age + 10
};
let anotherRecord = {
/* Comments should be correctly placed before ... expression */
...makeRecordBase(),
/* Comment after record extension */
name: "joe++",
age: testRecord.age + 10
};
let anotherRecord = {
/* Currently, type annotations must be wrapped in parens - that's easy to improve */
...(makeRecordBase () : withThreeFields),
name: "joe++",
age: testRecord.age + 10
};
let anotherRecord = {
/* This is meaningless, sure */
...someArray.[0] = 20,
name: "joe++",
age: testRecord.age + 10
};
let anotherRecord = {
...SomeReally.longFunctionCall {
passingRecordField: 0,
andThisOtherRecordField: 10
},
name: "joe++",
age: testRecord.age + 10
};
let anotherRecord = {
...SomeReally.longFunctionCall(withArguments, thatWrap:bool),
name: "joe++",
age: testRecord.age + 10
};
let anotherRecord = {
...SomeReally.longFunctionCall
(withArg,
["and", "final", "list", "that", "should", "break"]),
name: "joe++",
age: testRecord.age + 10
};
/* Record type punning */
type props = {title: string};
type state = unit;
type component = {props};
type component2 = {props, state, updater: unit,};
type component3 = {props: M.props, state};
type mutableComponent = {mutable props};
type mutabeleComponent2 = {mutable props, mutable state, style: int,};
/* Don't pun parameterized types */
type description('props) = {
element: string,
tag: tag('props)
};
/* Don't pun types from other modules */
module Foo = {
type bar = {foo: Baz.foo};
};
/* Don't pun field names that aren't "simple" */
type foo = {
bar: Baz.bar,
qux: qux,
fooo: Fooo.fooo
};
let moreFoo = {
bar: Baz.bar,
qux: qux,
fooo: Fooo.fooo
};
/* record value punning */
let props = {title: "hi"};
/* no punning available for a single field. Can't tell the difference with a scope + expression */
let componentA = {props: props};
/* pun for real */
let componentB = {props: props, state: ()};
/* pun fields with module prefix too */
let foo = {Foo.foo: foo};
let bar = {Foo.foo: foo, bar: 1};
let bar = {bar: 1, Foo.foo: foo};
let bar = {Foo.foo: foo, Bar.bar: bar};
fun ({M.x: x, y: y}) => 1;
switch (foo) {
| {y: 1, M.x: x} => 2
};
/* Requested in #566 */
let break_after_equal = no_break_from_here(some_call(to_here));
/* Pexp_letexception */
let () = {
exception E;
raise(E)
};
/* # 1587: don't print fun keyword when printing Pexp_fun in a record expression */
{contents: fun () => ((): unit)};
/* #1556: Always break nested record/obj */
let z = {a: {b: c, d: e}, f: g};
let z = {a: {"b": c, "d": e}, f: g};
let z = {a: {pub b = c; pub d = e}, f: g};
let z = {"a": {"b": c, "d": e}, "f": g};
let z = {"a": {b: c, d: e}, "f": g};
let z = {"a": {pub b = c; pub d = e}, "f": g};
/**
* Unnecessary parens should be removed.
*/
let unitLambda = (()) => ();
let identifierLambda = (a) => ();
let underscoreLambda = (_) => ();
it("should remove parens", (a) => {
print_string("did it work?");
print_string("did it work?");
});
/* https://github.com/facebook/reason/issues/1554 */
(curNode^)##childNodes;
foo(preserveBraces => {
inCallback
});
foo(preserveBraces => {
inFirstPos
}, secondArg);
foo(oneArg, preserveBraces => {
inFirstPos
}, secondArg);
================================================
FILE: test/basicStructures.t/run.t
================================================
Format basicStructures
$ refmt ./input.re
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
let run = () => {
TestUtils.printSection("Basic Structures");
};
while (something) {
print_string("You're in a while loop");
print_newline();
};
for (i in 0 to 5) {
print_int(i);
print_newline();
for (i in 10 downto 0) {
print_string(
"Counting in reverse direction",
);
print_newline();
};
};
for (i in
0 to
endOfRangeMustBeSimple(expr, soWrap)) {
print_int(i);
print_newline();
for (i in
theSame(isTrue, ofThe, startOfRange) downto
0) {
print_string(
"Counting in reverse direction",
);
print_newline();
};
};
let x = foo^ ^.bar^;
let x = foo.bar^;
let x = foo#bar^;
let x = foo^.bar^;
let x = (foo^)#bar^;
/* Prefix operators:
* ! followed by zero or more appropriate_operator_suffix_chars (see the
* lexer).
* ? or ~ followed by at least one appropriate_operator_suffix_chars.
*/
let x = !(!(!foo)).bar;
let x = !foo.bar;
let x = !foo#bar;
let x = !(!foo).bar;
let x = !(!foo)#bar;
let x = !(!foo.bar);
let x = ?!(!foo.bar);
let x = ! ?!foo.bar;
let x = ~!(!foo.bar);
let x = ! ~!foo.bar;
let x = ~! ~!foo.bar;
let x = !!foo.bar;
let x = !!foo#bar;
let x = !~foo.bar;
let x = !~foo#bar;
let noParensNeeded = !blah.foo.bar;
let parensNeededAroundFirst = (!blah).foo.bar;
let parensNeededAroundSecond = (!blah.foo).bar;
let noParensNeeded = !blah#foo#bar;
let parensNeededAroundFirst = (!blah)#foo#bar;
let parensNeededAroundSecond = (!blah#foo)#bar;
let parensWithSpaceNeededAroundFirst =
(!(!blah))#foo#bar;
let parensWithSpaceNeededAroundSecond =
(!(!blah#foo))#bar;
let parensWithSpaceNeededAroundFirst =
(?!(+ blah))#foo#bar;
let parensWithSpaceNeededAroundSecond =
(?!(+ blah#foo))#bar;
let x = !(!foo.bar);
let x = !(!foo#bar);
let x = (-10);
let x = (-5.0);
let x = Some(-10);
let x = Some(-5.0);
let lazy(x) = 10;
let lazy((x: int)) = 10;
let lazy([]) = 10;
let lazy(true) = 10;
let lazy(#x) = 10;
let lazy(`Variant) = 10;
let lazy(`variant) = 10;
let lazy('0' .. '9') = 10;
let lazy((lazy(true))) = 10;
let lazy([%extend]) = 10;
/* Test precedence on access sugar */
let x = arr^[0];
let x = arr^[0];
let x = str^.[0];
let x = str^.[0];
let x = arr^[0] = 1;
let x = arr^[0] = 1;
/* Comments */
/*Below is an empty comment*/
/**/;
/** IF
*============================================================================
*/;
let (/++) = (+); /* // indicates the start of a comment, not an infix op */
let something =
if (self.ext.logSuccess) {
print_string("Did tap");
print_newline();
};
let logTapSuccess = self =>
if (self.ext.logSuccess) {
print_string("Did tap");
print_newline();
} else {
();
};
let logTapSuccess = self =>
if (self.ext.logSuccess) {
print_string("Did tap");
print_newline();
};
(!data).field = true;
(!data).field1.field2 = true;
(!data.field1).field2 = true;
(!data).field1.field2 = true;
(!data.field1).field2 = true;
let loop = (appTime, frameTime) => {
if (hasSetup.contents) {
setupScene();
renderIntoTop();
hasSetup.contents = true;
};
process(appTime, frameTime);
};
/* These parens should be kept around the entire last if/then/else */
if (something) {
if (somethingElse) {()} else {"blah"};
};
/* These parens should be kept around just the last if/then*/
if (something) {
if (somethingElse) {()} else {"blah"};
};
/* Parens should be generated to wrap the entire final if then else.
* To test that it's being parsed correclty, should print "one". */
if (true) {
if (true) {
print_string("one");
} else {
print_string("two");
};
};
/* Should print two */
if (true) {
if (false) {
print_string("one");
} else {
print_string("two");
};
};
/* Should not print */
if (false) {
if (true) {
print_string("one");
} else {
print_string("two");
};
};
/* Should wrap (if a > b then a else b).
* printer(
*/
let printIfFirstArgGreater = true;
let result =
if (printIfFirstArgGreater) {
(a, b) =>
if (a > b) {
print_string("a > b");
} else {
print_string("b >= a");
};
} else if ({
(a, b) =>
if (a > b) {
print_string("b < a");
} else {
print_string("a <= b");
};
}) {
print_string(
"That could never possibly type check",
);
print_newline();
};
let myRecord = {
nestedRecord: {
anotherNestedRecord:
(instaComp, displayRect) =>
if (Graphics.cgRectIntersectsWithSlop(
defaultCompositeTimerRectSlop,
instaComp.relativeRect,
displayRect,
)) {
IoEligible;
} else {
IoInelibleButTryComposition;
},
},
};
if (printIfFirstArgGreater) {
(a, b) =>
if (a > b) {
print_string("a > b");
};
} else {
(a, b) =>
if (a > b) {
print_string("b < a");
};
};
/* Should Be Parsed As: Cleary a type error, but at least the parsing makes that clear */
if (printIfFirstArgGreater) {
(a, b) =>
if (a > b) {
print_string("a > b");
} else {
(a, b) =>
if (a > b) {
print_string("b < a");
};
};
};
(a, b) =>
if (a > b) {
print_string("a > b");
};
/* What you probably wanted was: */
if (printIfFirstArgGreater) {
(a, b) =>
if (a > b) {
print_string("a > b");
};
} else {
(a, b) =>
if (a > b) {
print_string("b < a");
};
};
/* Mutative if statement: Not used to evaluate to something. */
if (10 < 100) {
let msg = "If there was any doubt, 10 is in fact less than 100.";
print_string(msg);
} else {
let msg = "All bets are off.";
print_string(msg);
};
if (10 < 100) {
print_string(
"If there was any doubt, 10 is in fact less than 100.",
);
} else {
print_string("All bets are off.");
};
/** TYPE CONSTRAINTS
*============================================================================
*/;
let x: int = 10;
let x: int = 10;
let (x: int) = 10;
let (x: int) = (10: int);
/* let (x:int) = (10:string); */
/* let (x:string) = ("hello":int); */
/** TUPLES
*============================================================================
*/;
/* In Reason, types look like the data they model! Tuples are no exception. */
type pairOfInts = (int, int);
let (letBindingWithTypeConstraint: int) = 10;
let (tupleItem: int, withTypeConstraint: int) = (
10,
20,
);
/* To make sure that tuple field annotations are annotating the entire field */
let _dummyFunc = x => 10;
let annotatingFuncApplication = (
_dummyFunc("a"): int,
_dummyFunc("a"): int,
);
/* Pretty printer might stick the [int] at the label. */
let annotatingSingleFuncApplication: int =
_dummyFunc("a");
/* So lets try a place where it won't */
let annotatingSingleFuncApplication = {
/* Commenting a let binding. */
let a = 100;
/* Commenting another let binding. */
let int = 200;
/*
* This demonstrates why named arguments cannot simply have the form (func
* arg:val) - it is indistinguishable from a type constraint.
*/
2 + (_dummyFunc(a): int);
};
let (
tupleItem: int,
constrainedWithoutGrouping: int,
) = (
10,
20,
);
let (tupleItem, withOutsideTypeConstraint): (
int,
int,
) = (
10,
20,
);
/* Trailing commas */
let trailingCommaAccepted = (1, 2);
let moreTrailing = (1, 2, 3, 4, 5, 7);
/** Immutable Lists
* ============================================================================
*/;
/* Anatomy: -Head- --------- Tail--------- nil: You can't see nil */
let x: list(int) = [1, 2, 3, 4, 5, 6, 7, 8, 9];
let hd = "appendedToHead";
let tl = ["listTo", "append", "to"];
/* To push *one* and only *one* item to the front of a list - use [hd, ...tl] */
let result: list(string) = [hd, ...tl];
/* Is the same as writing */
let result: list(string) = [
"appendedToHead",
"listTo",
"append",
"to",
];
/* To operate on lists, use pattern matching */
let rec size =
fun
| [] => 0
| [hd, ...tl] => 1 + size(tl);
/* Optimize for tail recursion */
let rec size = (soFar, lst) =>
switch (lst) {
| [] => 0
| [hd, ...tl] => size(soFar + 1, tl)
};
let nestedMatch = lstLst =>
switch (lstLst) {
| [hd, ...tl] when false => 10
| [hd, ...tl] =>
switch (tl) {
| [] => 0 + 0
| [tlHd, ...tlTl] => 0 + 1
}
| [] => 0
};
let nestedMatchWithWhen = lstLst =>
switch (lstLst) {
| [hd, ...tl] when false => 10
| [hd, ...tl] when true =>
switch (tl) {
| [] when false => 0 + 0
| [] when true => 0 + 0
| [tlHd, ...tlTl] => 0 + 1
}
| [] => 0
};
/**
* Aliasing with "as" during matches.
*/;
type mine =
| MyThing(int)
| YourThing(int);
/*
* Reason parses "as" aliases differently than OCaml.
*/
let ppp =
switch (MyThing(20)) {
| MyThing(x) as ppp
| YourThing(x) as ppp => ppp
};
let MyThing(_) as ppp | YourThing(_) as ppp = ppp;
/*
* in order to achieve the previous example in ocaml, you would have to group
* as:
*/
let ppp =
switch (MyThing(20)) {
| MyThing(x) as ppp
| YourThing(x) as ppp => ppp
};
let MyThing(_) as ppp | YourThing(_) as ppp = ppp;
/*
* But this isn't needed in Reason because OR patterns have much lower
* precedence - they should be pretty printed in the same way.
*/
/* TODO: */
/* let rec nestedMatch lstLst => match lstLst with { */
/* hd::tl: match tl with { */
/* []: 0 + 0, */
/* tlHd::tlTl: 0 + 1, */
/* }, */
/* []: 0 */
/* }; */
/* */
/** ARRAYS
* ============================================================================
* Arrays are weird looking. Usually you want lists because they support pattern
* matching - that's why they have nicer syntax - to entice you. But if you want
* random access and better control over memory layout, use arrays.
*/;
let emptyArray = [||];
let arrayWithOne = [|10|];
let arrayWithTwo = [|10, 10|];
let secondItem = arrayWithTwo[1];
/* Getting And Setting: Yeah, we should really change this */
/* Get an array item at index 1 */
let secondItem = arrayWithTwo[1];
/* Set an array item at index 1 */
arrayWithTwo[1] = 300;
/**
* STRINGS
* ============================================================================
* The language supports mutating strings, but that should not be depended upon.
*/;
let myString = "asdf";
myString.[2] = '9'; /* Replacing a character: I could do without this sugar */
/* FUNCTIONS
*=============================================================================
*/
/* TYPE ANNOTATIONS
* =============================================================================
*/
let one = 900;
let two = 10000;
/* Tuple expressions can be annotated without additional paren wrapping */
let myTuple = (one: int, two: int);
type myTupleType = (int, int);
let myTuple: myTupleType = myTuple;
/* Anything *outside* of a tuple, must still be annotated within parens. */
let myTuple: myTupleType = (one: int, two: int);
/* Now functions that accept a single argument being a tuple look familiar */
let addValues = (a: int, b: int) => {
a + b;
};
let addValues = (a: int, b: int) => {
a + b;
};
let myFunction = (a: int, b: int): int => a + b;
let functionReturnValueType =
(i: int, s: string): (int => int) =>
x => x + 1;
let curriedFormOne = (i: int, s: string) =>
s ++ string_of_int(i);
let curriedFormTwo =
(i: int, x: int): (int, int) => (
i,
x,
);
/* let nonCurriedFormTwo = fun (i:int, x:int) (:(int, int)) => (i, x); */
let curriedFormThree =
(i: int, (a: int, b: int): (int, int))
: (int, int, int) => (
i,
a,
b,
);
/* let nonCurriedFormThree = fun (i:int, (a:int, b:int):(int, int)) (:(int, int, int)) => (i, a, b); */
/** TODO: But this, however doesn't work.
* let (myCurriedFunc: int => int) a => a;
* Note: This is likely because only "simple patterns" are accepted as constraints
* in let bindings - that may be easy to change.
*/;
type myFuncType = (int, int) => int;
let myFunc: myFuncType = (a, b) => a + b;
let funcWithTypeLocallyAbstractTypes =
(
type atype,
type btype,
a,
b,
c: (atype, btype) => unit,
) =>
c(a, b);
/* Checks that function types aren't unnecessary wrapped */
type a = unit => unit;
type b =
| Foo(unit => unit)
| Bar(unit => unit, unit => unit, (a, b) => c)
| Baz(
unit => unit,
unit => unit,
(a, b) => c,
);
type c =
| Foo((a, b) => unit)
| Bar((a, b) => unit);
type d = [> | `Foo(unit => unit)];
/**
* Records:
*=============================================================================
*/;
type withThreeFields = {
name: string,
age: int,
occupation: string,
};
let testRecord = {
name: "joe",
age: 20,
occupation: "engineer",
};
let anotherRecord = {
...testRecord,
name: "joe++",
age: testRecord.age + 10,
};
let makeRecordBase = () => {
name: "Joe",
age: 30,
occupation: "Engineer",
};
let anotherRecord = {
/* These parens should be evaporated. */
...makeRecordBase(),
name: "joe++",
age: testRecord.age + 10,
};
let anotherRecord = {
/* Comments should be correctly placed before ... expression */
...makeRecordBase(),
/* Comment after record extension */
name: "joe++",
age: testRecord.age + 10,
};
let anotherRecord = {
/* Currently, type annotations must be wrapped in parens - that's easy to improve */
...(makeRecordBase(): withThreeFields),
name: "joe++",
age: testRecord.age + 10,
};
let anotherRecord = {
/* This is meaningless, sure */
...someArray.[0] = 20,
name: "joe++",
age: testRecord.age + 10,
};
let anotherRecord = {
...
SomeReally.longFunctionCall({
passingRecordField: 0,
andThisOtherRecordField: 10,
}),
name: "joe++",
age: testRecord.age + 10,
};
let anotherRecord = {
...
SomeReally.longFunctionCall(
withArguments,
thatWrap: bool,
),
name: "joe++",
age: testRecord.age + 10,
};
let anotherRecord = {
...
SomeReally.longFunctionCall(
withArg,
[
"and",
"final",
"list",
"that",
"should",
"break",
],
),
name: "joe++",
age: testRecord.age + 10,
};
/* Record type punning */
type props = {title: string};
type state = unit;
type component = {props};
type component2 = {
props,
state,
updater: unit,
};
type component3 = {
props: M.props,
state,
};
type mutableComponent = {mutable props};
type mutabeleComponent2 = {
mutable props,
mutable state,
style: int,
};
/* Don't pun parameterized types */
type description('props) = {
element: string,
tag: tag('props),
};
/* Don't pun types from other modules */
module Foo = {
type bar = {foo: Baz.foo};
};
/* Don't pun field names that aren't "simple" */
type foo = {
bar: Baz.bar,
qux,
fooo: Fooo.fooo,
};
let moreFoo = {
bar: Baz.bar,
qux,
fooo: Fooo.fooo,
};
/* record value punning */
let props = { title: "hi" };
/* no punning available for a single field. Can't tell the difference with a scope + expression */
let componentA = { props: props };
/* pun for real */
let componentB = {
props,
state: (),
};
/* pun fields with module prefix too */
let foo = { Foo.foo: foo };
let bar = {
Foo.foo,
bar: 1,
};
let bar = {
bar: 1,
Foo.foo,
};
let bar = {
Foo.foo,
Bar.bar,
};
({ M.x, y }) => 1;
switch (foo) {
| { y: 1, M.x } => 2
};
/* Requested in #566 */
let break_after_equal =
no_break_from_here(some_call(to_here));
/* Pexp_letexception */
let () = {
exception E;
raise(E);
};
/* # 1587: don't print fun keyword when printing Pexp_fun in a record expression */
{ contents: () => ((): unit) };
/* #1556: Always break nested record/obj */
let z = {
a: {
b: c,
d: e,
},
f: g,
};
let z = {
a: {
"b": c,
"d": e,
},
f: g,
};
let z = {
a: {
pub b = c;
pub d = e
},
f: g,
};
let z = {
"a": {
"b": c,
"d": e,
},
"f": g,
};
let z = {
"a": {
b: c,
d: e,
},
"f": g,
};
let z = {
"a": {
pub b = c;
pub d = e
},
"f": g,
};
/**
* Unnecessary parens should be removed.
*/
let unitLambda = () => ();
let identifierLambda = a => ();
let underscoreLambda = _ => ();
it("should remove parens", a => {
print_string("did it work?");
print_string("did it work?");
});
/* https://github.com/facebook/reason/issues/1554 */
(curNode^)##childNodes;
foo(preserveBraces => {inCallback});
foo(preserveBraces => {inFirstPos}, secondArg);
foo(
oneArg,
preserveBraces => {inFirstPos},
secondArg,
);
================================================
FILE: test/basics.t/input.re
================================================
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
let l = [1,2,3] |> List.map (i => i+1, _) |> List.filter (i => i>0, _);
let l = (i => i+1) |> List.map(_, [1,2,3]);
let x = List.length(_);
let nested = x => List.length(_);
let incr = (~v) => v+1;
let l1 = [1,2,3] |> List.map(incr(~v=_)) |> List.length;
let l2 = [1,2,3] |> List.map(incr(~v =_)) |> List.length;
let a1 = [|1, 2, 3|] |> Array.get(_, 1);
let s1 = "roses are red" |> String.get(_, 4);
let optParam = (~v=?, ()) => v == None ? 0 : 1;
let l1 =
[Some(1), None, Some(2)] |> List.map(optParam(~v=?_, ())) |> List.length;
let l2 =
[Some(1), None, Some(2)] |> List.map(optParam(~v =?_, ())) |> List.length;
let argIsUnderscore1 = _ => 34;
let argIsUnderscore2 = (_ => 34);
let argIsUnderscore3 = _ : int => 34;
let argIsUnderscore4 = (_ : int => 34);
let argIsUnderscore5 = (_: int) => 34;
let argIsUnderscore6 = ((_: int) => 34);
type reasonXyz =
| X
| Y(int,int,int)
| Z(int,int)
| Q
| R;
type reasonXyzWithOf =
| X
| Y(int,int,int)
| Z(int,int)
| Q
| R;
let reasonBarAs = fun
| ((Y(_) | Z(_)) as t, _) => {let _ = t; true}
| _ => false;
let reasonDoubleBar = fun
| X | Y(_,_,_) | Z(_,_) | Q => true
| _ => false;
let reasonDoubleBarNested = fun
| X | Y(_,_,_) | (Z(_,_) | Q) => true
| _ => false;
/* Liberal use of the Any pattern being compatible with multiple
arguments */
let reasonDoubleBarAnyPatterns = fun
| X | Y(_) | Z(_) | Q => true
| _ => false;
let reasonDoubleBarNestedAnyPatterns = fun
| X | Y(_) | (Z(_) | Q) => true
| _ => false;
let (\+) = (+);
let a = 2.0 ** 4.0;
let (\===) = (===);
let expectedPrecendence = 1 + 1 \=== 1 + 1 && 1 + 1 \!== 1 + 1;
let expectedPrecendence = 1 \+ 1 \=== 1 \+ 1 && 1 \+ 1 \!== 1 \+ 1;
module X: {let x: (~x: unit=?, unit) => unit;} = {
let x(~x=(),()) = ();
};
let display (~message=("hello": string), ~person: string="Reason", time: float) = 1;
let not = (x, y) => x + y;
let added: int = not(1, 2);
let better = foo => !foo ? 42 : not(41, 2);
================================================
FILE: test/basics.t/run.t
================================================
Format basic
$ refmt --print re ./input.re > ./formatted.re
Print formatted file
$ cat ./formatted.re
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
let l =
[1, 2, 3]
|> List.map(i => i + 1, _)
|> List.filter(i => i > 0, _);
let l = (i => i + 1) |> List.map(_, [1, 2, 3]);
let x = List.length(_);
let nested = x => List.length(_);
let incr = (~v) => v + 1;
let l1 =
[1, 2, 3]
|> List.map(incr(~v=_))
|> List.length;
let l2 =
[1, 2, 3]
|> List.map(incr(~v=_))
|> List.length;
let a1 = [|1, 2, 3|] |> Array.get(_, 1);
let s1 = "roses are red" |> String.get(_, 4);
let optParam = (~v=?, ()) => v == None ? 0 : 1;
let l1 =
[Some(1), None, Some(2)]
|> List.map(optParam(~v=?_, ()))
|> List.length;
let l2 =
[Some(1), None, Some(2)]
|> List.map(optParam(~v=?_, ()))
|> List.length;
let argIsUnderscore1 = _ => 34;
let argIsUnderscore2 = _ => 34;
let argIsUnderscore3 = _: int => 34;
let argIsUnderscore4 = _: int => 34;
let argIsUnderscore5 = (_: int) => 34;
let argIsUnderscore6 = (_: int) => 34;
type reasonXyz =
| X
| Y(int, int, int)
| Z(int, int)
| Q
| R;
type reasonXyzWithOf =
| X
| Y(int, int, int)
| Z(int, int)
| Q
| R;
let reasonBarAs =
fun
| ((Y(_) | Z(_)) as t, _) => {
let _ = t;
true;
}
| _ => false;
let reasonDoubleBar =
fun
| X
| Y(_, _, _)
| Z(_, _)
| Q => true
| _ => false;
let reasonDoubleBarNested =
fun
| X
| Y(_, _, _)
| Z(_, _)
| Q => true
| _ => false;
/* Liberal use of the Any pattern being compatible with multiple
arguments */
let reasonDoubleBarAnyPatterns =
fun
| X
| Y(_)
| Z(_)
| Q => true
| _ => false;
let reasonDoubleBarNestedAnyPatterns =
fun
| X
| Y(_)
| Z(_)
| Q => true
| _ => false;
let (\+) = (+);
let a = 2.0 ** 4.0;
let (\===) = (===);
let expectedPrecendence =
1 + 1 \=== 1 + 1 && 1 + 1 !== 1 + 1;
let expectedPrecendence =
1 \+ 1 \=== 1 \+ 1 && 1 \+ 1 !== 1 \+ 1;
module X: {
let x: (~x: unit=?, unit) => unit;
} = {
let x = (~x=(), ()) => ();
};
let display =
(
~message=("hello": string),
~person: string="Reason",
time: float,
) => 1;
let not = (x, y) => x + y;
let added: int = not(1, 2);
let better = foo => !foo ? 42 : not(41, 2);
Type-check basics
$ ocamlc -c -pp 'refmt --print binary' -intf-suffix .rei -impl formatted.re
Format the formatted file back
$ refmt --print re ./formatted.re > ./formatted_back.re
Ensure idempotency: first format and second format are the same
$ diff formatted.re formatted_back.re
================================================
FILE: test/basics_no_semi.t/input.re
================================================
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
let l = [1,2,3] |> List.map (i => i+1, _) |> List.filter (i => i>0, _)
let l = (i => i+1) |> List.map(_, [1,2,3])
let x = List.length(_)
let nested = x => List.length(_)
let incr = (~v) => v+1
let l1 = [1,2,3] |> List.map(incr(~v=_)) |> List.length
let l2 = [1,2,3] |> List.map(incr(~v =_)) |> List.length
let a1 = [|1, 2, 3|] |> Array.get(_, 1)
let s1 = "roses are red" |> String.get(_, 4)
let optParam = (~v=?, ()) => v == None ? 0 : 1
let l1 =
[Some(1), None, Some(2)] |> List.map(optParam(~v=?_, ())) |> List.length
let l2 =
[Some(1), None, Some(2)] |> List.map(optParam(~v =?_, ())) |> List.length
let argIsUnderscore1 = _ => 34
let argIsUnderscore2 = (_ => 34)
let argIsUnderscore3 = _ : int => 34
let argIsUnderscore4 = (_ : int => 34)
let argIsUnderscore5 = (_: int) => 34
let argIsUnderscore6 = ((_: int) => 34)
type reasonXyz =
| X
| Y(int,int,int)
| Z(int,int)
| Q
| R
type reasonXyzWithOf =
| X
| Y(int,int,int)
| Z(int,int)
| Q
| R
let reasonBarAs = fun
| ((Y(_) | Z(_)) as t, _) => {let _ = t; true}
| _ => false
let reasonDoubleBar = fun
| X | Y(_,_,_) | Z(_,_) | Q => true
| _ => false
let reasonDoubleBarNested = fun
| X | Y(_,_,_) | (Z(_,_) | Q) => true
| _ => false
/* Liberal use of the Any pattern being compatible with multiple
arguments */
let reasonDoubleBarAnyPatterns = fun
| X | Y(_) | Z(_) | Q => true
| _ => false
let reasonDoubleBarNestedAnyPatterns = fun
| X | Y(_) | (Z(_) | Q) => true
| _ => false
let (\+) = (+)
let a = 2.0 ** 4.0
let (\===) = (===)
let expectedPrecendence = 1 + 1 \=== 1 + 1 && 1 + 1 \!== 1 + 1
let expectedPrecendence = 1 \+ 1 \=== 1 \+ 1 && 1 \+ 1 \!== 1 \+ 1
module X: {let x: (~x: unit=?, unit) => unit} = {
let x(~x=(),()) = ()
}
let display (~message=("hello": string), ~person: string="Reason", time: float) = 1
let not = (x, y) => x + y
let added: int = not(1, 2)
let better = foo => !foo ? 42 : not(41, 2)
================================================
FILE: test/basics_no_semi.t/run.t
================================================
Format basic
$ refmt --print re ./input.re > ./formatted.re
Print formatted file
$ cat ./formatted.re
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
let l =
[1, 2, 3]
|> List.map(i => i + 1, _)
|> List.filter(i => i > 0, _);
let l = (i => i + 1) |> List.map(_, [1, 2, 3]);
let x = List.length(_);
let nested = x => List.length(_);
let incr = (~v) => v + 1;
let l1 =
[1, 2, 3]
|> List.map(incr(~v=_))
|> List.length;
let l2 =
[1, 2, 3]
|> List.map(incr(~v=_))
|> List.length;
let a1 = [|1, 2, 3|] |> Array.get(_, 1);
let s1 = "roses are red" |> String.get(_, 4);
let optParam = (~v=?, ()) => v == None ? 0 : 1;
let l1 =
[Some(1), None, Some(2)]
|> List.map(optParam(~v=?_, ()))
|> List.length;
let l2 =
[Some(1), None, Some(2)]
|> List.map(optParam(~v=?_, ()))
|> List.length;
let argIsUnderscore1 = _ => 34;
let argIsUnderscore2 = _ => 34;
let argIsUnderscore3 = _: int => 34;
let argIsUnderscore4 = _: int => 34;
let argIsUnderscore5 = (_: int) => 34;
let argIsUnderscore6 = (_: int) => 34;
type reasonXyz =
| X
| Y(int, int, int)
| Z(int, int)
| Q
| R;
type reasonXyzWithOf =
| X
| Y(int, int, int)
| Z(int, int)
| Q
| R;
let reasonBarAs =
fun
| ((Y(_) | Z(_)) as t, _) => {
let _ = t;
true;
}
| _ => false;
let reasonDoubleBar =
fun
| X
| Y(_, _, _)
| Z(_, _)
| Q => true
| _ => false;
let reasonDoubleBarNested =
fun
| X
| Y(_, _, _)
| Z(_, _)
| Q => true
| _ => false;
/* Liberal use of the Any pattern being compatible with multiple
arguments */
let reasonDoubleBarAnyPatterns =
fun
| X
| Y(_)
| Z(_)
| Q => true
| _ => false;
let reasonDoubleBarNestedAnyPatterns =
fun
| X
| Y(_)
| Z(_)
| Q => true
| _ => false;
let (\+) = (+);
let a = 2.0 ** 4.0;
let (\===) = (===);
let expectedPrecendence =
1 + 1 \=== 1 + 1 && 1 + 1 !== 1 + 1;
let expectedPrecendence =
1 \+ 1 \=== 1 \+ 1 && 1 \+ 1 !== 1 \+ 1;
module X: {
let x: (~x: unit=?, unit) => unit;
} = {
let x = (~x=(), ()) => ();
};
let display =
(
~message=("hello": string),
~person: string="Reason",
time: float,
) => 1;
let not = (x, y) => x + y;
let added: int = not(1, 2);
let better = foo => !foo ? 42 : not(41, 2);
Type-check basics
$ ocamlc -c -pp 'refmt --print binary' -intf-suffix .rei -impl formatted.re
Format the formatted file back
$ refmt --print re ./formatted.re > ./formatted_back.re
Ensure idempotency: first format and second format are the same
$ diff formatted.re formatted_back.re
================================================
FILE: test/bigarray.t/input.re
================================================
my_big_array3.{reallyLongStringThatWillDefinitelyBreakLine};
my_big_array3.{reallyLongStringThatWillDefinitelyBreakLine, reallyLongStringThatWillDefinitelyBreakLine};
my_big_array3.{reallyLongStringThatWillDefinitelyBreakLine, reallyLongStringThatWillDefinitelyBreakLine, reallyLongStringThatWillDefinitelyBreakLine};
my_big_array3.{reallyLongString, reallyLongString, reallyLongString, reallyLongString, reallyLongString};
my_big_array3.{reallyLongStringThatWillDefinitelyBreakLine} = 3.0;
my_big_array3.{reallyLongStringThatWillDefinitelyBreakLine, reallyLongStringThatWillDefinitelyBreakLine} = 3.0;
my_big_array3.{reallyLongString, reallyLongString, reallyLongString, reallyLongString, reallyLongString} = 3.0;
================================================
FILE: test/bigarray.t/run.t
================================================
Format bigarray
$ refmt ./input.re
my_big_array3.{
reallyLongStringThatWillDefinitelyBreakLine
};
my_big_array3.{
reallyLongStringThatWillDefinitelyBreakLine,
reallyLongStringThatWillDefinitelyBreakLine
};
my_big_array3.{
reallyLongStringThatWillDefinitelyBreakLine,
reallyLongStringThatWillDefinitelyBreakLine,
reallyLongStringThatWillDefinitelyBreakLine
};
my_big_array3.{
reallyLongString,
reallyLongString,
reallyLongString,
reallyLongString,
reallyLongString
};
my_big_array3.{
reallyLongStringThatWillDefinitelyBreakLine
} = 3.0;
my_big_array3.{
reallyLongStringThatWillDefinitelyBreakLine,
reallyLongStringThatWillDefinitelyBreakLine
} = 3.0;
my_big_array3.{
reallyLongString,
reallyLongString,
reallyLongString,
reallyLongString,
reallyLongString
} = 3.0;
================================================
FILE: test/bigarraySyntax.t/input.re
================================================
/* https://github.com/facebook/reason/issues/2038 */
let my_big_array1 =
Bigarray.Array1.create(Bigarray.float32, Bigarray.c_layout, 20);
my_big_array1.{1};
my_big_array1.{1} = 1.0;
let my_big_array2 =
Bigarray.Array2.create(Bigarray.float32, Bigarray.c_layout, 20, 20);
my_big_array2.{1, 2};
my_big_array2.{1, 2} = 1.0;
let my_big_array3 =
Bigarray.Array3.create(Bigarray.float32, Bigarray.c_layout, 20, 20, 20);
my_big_array3.{1, 2, 3};
my_big_array3.{1, 2, 3} = 1.0;
let reallyLongStringThatWillDefinitelyBreakLine = 0;
my_big_array3.{reallyLongStringThatWillDefinitelyBreakLine, reallyLongStringThatWillDefinitelyBreakLine, reallyLongStringThatWillDefinitelyBreakLine};
my_big_array3.{reallyLongStringThatWillDefinitelyBreakLine, reallyLongStringThatWillDefinitelyBreakLine, reallyLongStringThatWillDefinitelyBreakLine} = 3.0;
================================================
FILE: test/bigarraySyntax.t/run.t
================================================
Format basic
$ refmt --print re ./input.re > ./formatted.re
Print the formatted file
$ cat ./formatted.re
/* https://github.com/facebook/reason/issues/2038 */
let my_big_array1 =
Bigarray.Array1.create(
Bigarray.float32,
Bigarray.c_layout,
20,
);
my_big_array1.{1};
my_big_array1.{1} = 1.0;
let my_big_array2 =
Bigarray.Array2.create(
Bigarray.float32,
Bigarray.c_layout,
20,
20,
);
my_big_array2.{1, 2};
my_big_array2.{1, 2} = 1.0;
let my_big_array3 =
Bigarray.Array3.create(
Bigarray.float32,
Bigarray.c_layout,
20,
20,
20,
);
my_big_array3.{1, 2, 3};
my_big_array3.{1, 2, 3} = 1.0;
let reallyLongStringThatWillDefinitelyBreakLine = 0;
my_big_array3.{
reallyLongStringThatWillDefinitelyBreakLine,
reallyLongStringThatWillDefinitelyBreakLine,
reallyLongStringThatWillDefinitelyBreakLine
};
my_big_array3.{
reallyLongStringThatWillDefinitelyBreakLine,
reallyLongStringThatWillDefinitelyBreakLine,
reallyLongStringThatWillDefinitelyBreakLine
} = 3.0;
Type-check basics
$ ocamlc -c -pp 'refmt --print binary' -intf-suffix .rei -impl formatted.re
Format the formatted file back
$ refmt --print re ./formatted.re > ./formatted_back.re
Ensure idempotency: first format and second format are the same
$ diff formatted.re formatted_back.re
================================================
FILE: test/class.t/input.re
================================================
class aClass1(x) {
/* one value parameter x */
pub a1 = 0;
pub a2() = 0;
pub a3(x,y) = x + y;
pub a4(x,y) {
let result = x + y;
print_endline(" x + y = " ++ string_of_int(x) ++ " + " ++ string_of_int(y) ++ " = " ++ string_of_int(result));
result
};
};
class aClass2(x) {
};
class aClass3(x: (int => int)) {
};
class aClass4(x: (int => int => int)) {
};
class aClass5(x: (int => (int => int))) {
};
class aClass6(x: ((int => int) => int)) {
};
class aClass7(x: ((int, int) => int)) {
};
class labeledClass1(~x) {
};
class labeledClass2(~x: ((~y:int) => int)) {
};
class labeledClass3(~x: ((~y:int) => int => int)) {
};
class labeledClass4(~x: ((~y:int) => (int => int))) {
};
class labeledClass5(~x: (((~y:int) => int) => int)) {
};
class labeledClass6(~x: ((~y:(int, int)) => int)) {
};
================================================
FILE: test/class.t/run.t
================================================
See the typed tree from ./input.re
$ cat ./input.re | ../lib/outcometreePrinter.exe
class aClass1 :
('a) =>
{
pub a1: int;
pub a2: unit => int;
pub a3: (int, int) => int;
pub a4: (int, int) => int
};
class aClass2 : ('a) => { };
class aClass3 : (int, int) => { };
class aClass4 : (int, int, int) => { };
class aClass5 : (int, int, int) => { };
class aClass6 : (int => int, int) => { };
class aClass7 : (int, int, int) => { };
class labeledClass1 : ('a) => { };
class labeledClass2 : (~x: int, int) => { };
class labeledClass3 : (~x: int, int, int) => { };
class labeledClass4 : (~x: int, int, int) => { };
class labeledClass5 : ((~y: int) => int, int) => { };
class labeledClass6 : (~x: (int, int), int) => { };
================================================
FILE: test/class_types.t/input.re
================================================
class type _module ('provider_impl) = {
};
type t;
class type bzz = {
inherit _module(t)
};
class type t = { as 'a;
constraint 'a = #s
};
/* https://github.com/facebook/reason/issues/2037 */
class type xt = { as 'a };
class x = {
as self
};
class type classWithNoArgType {
pub x : int;
pub y : int
};
class classWithNoArg {
pub x = 0;
pub y = 0
};
class type t = {
open M;
as 'a;
};
class type t = {
open M;
};
================================================
FILE: test/class_types.t/run.t
================================================
Format class and class type
$ refmt ./input.re
class type _module ('provider_impl) = {};
type t;
class type bzz = {
inherit _module(t);
};
class type t = {
as 'a;
constraint 'a = #s;
};
/* https://github.com/facebook/reason/issues/2037 */
class type xt = {
as 'a;
};
class x = {
as self;
};
class type classWithNoArgType = {
pub x: int;
pub y: int;
};
class classWithNoArg = {
pub x = 0;
pub y = 0;
};
class type t = {
open M;
as 'a;
};
class type t = {
open M;
};
================================================
FILE: test/comments-ml.t/input.ml
================================================
(* **** comment *)
(*** comment *)
(** docstring *)
(* comment *)
(** docstring *)
(*** comment *)
(**** comment *)
(***** comment *)
(*** *)
(**** *)
(***)
(****)
(* (** comment *) *)
(* (*** comment *) *)
(* *(*** comment *) *)
(* comment **)
(* comment ***)
(* comment ****)
(* comment *****)
let testingNotQuiteEndOfLineComments = [
"Item 1"(* Comment For First Item *);
"Item 2" (* Comment For Second Item *);
"Item 3" (* Comment For Third Item *) ;
"Item 4" (* Comment For Fourth Item - but no semi *)
(* Comment after last item in list. *)
] (* Comment after list bracket *)
let testingEndOfLineComments = [
"Item 1";(* Comment For First Item *)
"Item 2"; (* Comment For Second Item *)
"Item 3"; (* Comment For Third Item *)
"Item 4" (* Comment For Fourth Item - but before semi *);
(* Comment after last item in list. *)
] (* Comment after list bracket *)
(* This time no space between bracket and comment *)
let testingEndOfLineComments = [
](* Comment after list bracket *)
type t = int * int (* End of line on t *)
type t22 = (* End of t22 line on type t22 = *)
int * int
type variant =
(* Comment above X *)
| X of int (* End of line on X *)
(* Comment above Y *)
| Y of int (* End of line on Y *)
(* Comment on entire type def for variant *)
type x = { (* not attached *above* x *)
fieldOne : int
} (* Attached end of line after x *)
and y = { (* not attached *above* y *)
fieldTwo : int
} (* Attached end of line after y *)
let result = match X 3 with
| X x -> (* Where does this comment go? *)
let tmp = x in
x + tmp
| Y x ->
(* How about this one *)
let tmp = x in
x + tmp
let result = match None with
| Some {fieldOne = 20} -> (* Where does this comment go? *)
let tmp = 0 in
2 + tmp
| Some {fieldOne = n} ->
(* How about this one *)
let tmp = n in
n + tmp
| None -> 20
type pointWithManyKindsOfComments = {
(* Line before x *)
x: string; (* x field *)
(* Line before y *)
y: string; (* y field *)
(* Final row of record *)
}
type 'a typeParamPointWithComments = {
(* Line before x *)
x: 'a; (* x field *)
(* Line before y *)
y: 'a (* y field *)
(* Final row of record *)
}
let name_equal x y = x = y
let equal i1 i2 =
i1.contents == i2.contents && true (* most unlikely first *)
let equal i1 i2 =
compare (compare 0 0) (compare 1 1) (* END OF LINE HERE *)
module Temp = struct
let v = true
let logIt str () = print_string str
end
let store_attributes arg =
let attributes_file = "test" in
let proc_name = attributes_file ^ ".proc" in
let should_write = (* only overwrite defined procedures *)
Temp.v ||
not (Temp.v) in
if should_write then
Temp.logIt proc_name ()
================================================
FILE: test/comments-ml.t/run.t
================================================
Format basic
$ refmt --print re ./input.ml > ./formatted.re
Type-check basics
$ ocamlc -c -pp 'refmt --print binary' -intf-suffix .rei -impl formatted.re
Format the formatted file back
$ refmt --print re ./formatted.re > ./formatted_back.re
Ensure idempotency: first format and second format are the same
$ diff formatted.re formatted_back.re
================================================
FILE: test/comments-mli.t/input.mli
================================================
(* **** comment *)
(*** comment *)
(** docstring *)
(* comment *)
(** docstring *)
(*** comment *)
(**** comment *)
(***** comment *)
(** *)
(*** *)
(**** *)
(***)
(****)
(** (** comment *) *)
(** (*** comment *) *)
(* (** comment *) *)
(* (*** comment *) *)
(* *(*** comment *) *)
(* comment **)
(* comment ***)
(* comment ****)
(* comment *****)
(**
* Multiline
*)
(** Multiline
*
*)
(**
**
*)
================================================
FILE: test/comments-mli.t/run.t
================================================
Format basic
$ refmt --print re ./input.mli > ./formatted.rei
Type-check basics
$ ocamlc -c -pp 'refmt --print binary' -intf-suffix .rei -intf formatted.rei
Format the formatted file back
$ refmt --print re ./formatted.rei > ./formatted_back.rei
Ensure idempotency: first format and second format are the same
$ diff formatted.rei formatted_back.rei
================================================
FILE: test/dune
================================================
(env
(_
(env-vars
(REFMT_PRINT_WIDTH 50))))
(cram
(applies_to * \ lib rtopIntegration)
(package reason)
(deps
%{bin:ocamlc}
%{bin:refmt}
./lib/outcometreePrinter.exe
./lib/fdLeak.exe))
(cram
(applies_to rtopIntegration)
(package rtop)
(enabled_if
(= %{os_type} Unix))
(deps %{bin:ocamlc} %{bin:rtop}))
================================================
FILE: test/emptyFileComment.t/input.re
================================================
// file with just a single line comment
================================================
FILE: test/emptyFileComment.t/run.t
================================================
Format empty file comment
$ refmt ./input.re
// file with just a single line comment
================================================
FILE: test/escapesInStrings.t/input.re
================================================
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
/*
let str = "@[.... some formatting ....@\n\010@.";
*/
let str = "@[.... some formatting ....@\n\010@.";
let str = {abcd|@[.... some formatting ....@\n\010@.|abcd};
let utf8_string = "😁";
let keep_representation = "\n
\t . this should be on a new line\
^ this should be aligned with the .
";
================================================
FILE: test/escapesInStrings.t/run.t
================================================
Format escapes in strings
$ refmt ./input.re
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
/*
let str = "@[.... some formatting ....@\n\010@.";
*/
let str = "@[.... some formatting ....@\n\010@.";
let str = {abcd|@[.... some formatting ....@\n\010@.|abcd};
let utf8_string = "😁";
let keep_representation = "\n
\t . this should be on a new line\
^ this should be aligned with the .
";
================================================
FILE: test/expr-constraint-with-vbct.t/input.re
================================================
/* Array literal with type constraint */
let x: array(int) = ([|1, 2|]: array(int));
/* List literal with type constraint */
let x: list(int) = ([1, 2, 3]: list(int));
/* Tuple with type constraint */
let x: (int, string) = ((1, "a"): (int, string));
/* Function expression with type constraint */
let f: int => int = ((x => x + 1): int => int);
/* Record with type constraint */
type t = {a: int};
let x: t = ({a: 1}: t);
================================================
FILE: test/expr-constraint-with-vbct.t/run.t
================================================
Format expression type constraints when binding also has a type constraint
$ refmt ./input.re | tee formatted.re
/* Array literal with type constraint */
let x: array(int) = ([|1, 2|]: array(int));
/* List literal with type constraint */
let x: list(int) = ([1, 2, 3]: list(int));
/* Tuple with type constraint */
let x: (int, string) = (
(1, "a"): (int, string)
);
/* Function expression with type constraint */
let f: int => int = (x => x + 1: int => int);
/* Record with type constraint */
type t = {a: int};
let x: t = ({ a: 1 }: t);
Idempotency check
$ refmt ./formatted.re | tee formatted_back.re
/* Array literal with type constraint */
let x: array(int) = ([|1, 2|]: array(int));
/* List literal with type constraint */
let x: list(int) = ([1, 2, 3]: list(int));
/* Tuple with type constraint */
let x: (int, string) = (
(1, "a"): (int, string)
);
/* Function expression with type constraint */
let f: int => int = (x => x + 1: int => int);
/* Record with type constraint */
type t = {a: int};
let x: t = ({ a: 1 }: t);
$ diff formatted.re formatted_back.re
================================================
FILE: test/extension-exprs.t/input.re
================================================
/* Extension with pexp_apply */
[%defer
cleanup();
];
/* Extension with comment with pexp_apply */
[%defer
/* 2. comment attached to expr in extension */
cleanup();
];
/* Let sequence + extension with pexp_apply */
let () = {
/* random let binding */
let x = 1;
/* 1. comment attached to extension */
[%defer cleanup()];
/* 3. comment attached to next expr */
something_else();
};
/* Let sequence + extension with comment with pexp_apply */
let () = {
/* random let binding */
let x = 1;
/* 1. comment attached to extension */
[%defer
/* 2. comment attached to expr in extension */
cleanup()
];
/* 3. comment attached to next expr */
something_else();
};
================================================
FILE: test/extension-exprs.t/run.t
================================================
Format extensions
$ refmt ./input.re
/* Extension with pexp_apply */
[%defer cleanup()];
/* Extension with comment with pexp_apply */
[%defer
/* 2. comment attached to expr in extension */
cleanup()
];
/* Let sequence + extension with pexp_apply */
let () = {
/* random let binding */
let x = 1;
/* 1. comment attached to extension */
[%defer cleanup()];
/* 3. comment attached to next expr */
something_else();
};
/* Let sequence + extension with comment with pexp_apply */
let () = {
/* random let binding */
let x = 1;
/* 1. comment attached to extension */
[%defer
/* 2. comment attached to expr in extension */
cleanup()
];
/* 3. comment attached to next expr */
something_else();
};
================================================
FILE: test/extension-str-in-module.t
================================================
Format extensions in modules
$ refmt <<EOF
> [%%toplevelExtension "payload"];
> module X = {
> /* No payload */
> [%%someExtension];
> [%%someExtension "payload"];
> };
> EOF
[%%toplevelExtension "payload"];
module X = {
/* No payload */
[%%someExtension];
[%%someExtension "payload"];
};
================================================
FILE: test/extensions.t/input.re
================================================
/* Extension sugar */
[%extend open M];
[%extend module M = {}];
[%extend module type M = {}];
type a = [%extend int];
let%extend x = "hi";
let x = {
let%extend x = ();
ignore();
[%extend ignore()];
let%extend x = ();
[%extend return("hi")];
};
let x = {
if%extend (true) {1} else {2};
switch%extend (None) {
| Some(x) => assert(false)
| None => ()
};
try%extend(raise(Not_found)) {
| Not_found => ()
| Invalid_argument(msg) => prerr_endline(msg)
};
};
let x = {
if%extend (true) {1} else {2};
};
let x = {
switch%extend (None) {
| Some(x) => assert(false)
| None => ()
};
};
let x = {
try%extend(raise(Not_found)) {
| Not_found => ()
| Invalid_argument(msg) => prerr_endline(msg)
};
};
/* At structure level */
try%extend() {
| _ => ()
};
switch%extend () {
| _ => ()
};
if%extend (true) {1} else {2};
for%extend (i in 1 to 10) {
();
};
while%extend (false) {
();
};
[%extend () => ()];
fun%extend
| None => ()
| Some(1) => ();
/* In a top-level binding */
let x =
try%extend() {
| _ => ()
};
let x =
switch%extend () {
| _ => ()
};
let x = if%extend (true) {1} else {2};
let x =
for%extend (i in 1 to 10) {
();
};
let x =
while%extend (false) {
();
};
let x = [%extend () => ()];
let x =
fun%extend
| None => ()
| Some(1) => ();
/* With two extensions, alone */
let x = {
[%extend1
try%extend2() {
| _ => ()
}];
};
let x = {
[%extend1
switch%extend2 () {
| _ => ()
}];
};
let x = {
[%extend1 if%extend2 (true) {1} else {2}];
};
let x = {
[%extend1
for%extend2 (i in 1 to 10) {
();
}];
};
let x = {
[%extend1
while%extend2 (false) {
();
}];
};
let x = {
[%extend1 [%extend2 () => ()]];
};
let x = {
[%extend1
fun%extend2
| None => ()
| Some(1) => ()];
};
/* With two extensions, first in sequence */
let x = {
[%extend1
try%extend2() {
| _ => ()
}];
ignore();
};
let x = {
ignore();
[%extend1
switch%extend2 () {
| _ => ()
}];
ignore();
};
let x = {
ignore();
[%extend1 if%extend2 (true) {1} else {2}];
ignore();
};
let x = {
ignore();
[%extend1
for%extend2 (i in 1 to 10) {
();
}];
ignore();
};
let x = {
ignore();
[%extend1
while%extend2 (false) {
();
}];
ignore();
};
let x = {
ignore();
[%extend1 [%extend2 () => ()]];
ignore();
};
let x = {
ignore();
[%extend1
fun%extend2
| None => ()
| Some(1) => ()];
};
/* With two extensions, in sequence */
let x = {
ignore();
[%extend1
try%extend2() {
| _ => ()
}];
ignore();
};
let x = {
ignore();
[%extend1
switch%extend2 () {
| _ => ()
}];
ignore();
};
let x = {
ignore();
[%extend1 if%extend2 (true) {1} else {2}];
ignore();
};
let x = {
ignore();
[%extend1
for%extend2 (i in 1 to 10) {
();
}];
ignore();
};
let x = {
ignore();
[%extend1
while%extend2 (false) {
();
}];
ignore();
};
let x = {
ignore();
[%extend1 [%extend2 () => ()]];
ignore();
};
let x = {
ignore();
[%extend1
fun%extend2
| None => ()
| Some(1) => ()];
ignore();
};
/* With two extensions, second in sequence */
let x = {
ignore();
[%extend1
try%extend2() {
| _ => ()
}];
};
let x = {
ignore();
[%extend1
switch%extend2 () {
| _ => ()
}];
};
let x = {
ignore();
[%extend1 if%extend2 (true) {1} else {2}];
};
let x = {
ignore();
[%extend1
for%extend2 (i in 1 to 10) {
();
}];
};
let x = {
ignore();
[%extend1
while%extend2 (false) {
();
}];
};
let x = {
ignore();
[%extend1 [%extend2 () => ()]];
};
let x = {
ignore();
[%extend1
fun%extend2
| None => ()
| Some(1) => ()];
};
let _ =
switch%ext (expr) {
| A =>
/* Comment under A */
()
| B => ()
};
/* comments in presence of extension point syntax #1938 */
let () = {
/* 1. comment attached to extension */
[%defer
/* 2. comment attached to expr in extension */
cleanup()];
/* 3. comment attached to next expr */
something_else();
};
/* comments in presence of extension point syntax #1938 */
let () = {
/* random let binding */
let x = 1;
/* 1. comment attached to extension */
[%defer
/* 2. comment attached to expr in extension */
cleanup()];
/* 3. comment attached to next expr */
something_else();
};
let work = () => {
open Syntax;
let%bind name = x;
name;
};
/* Extensions can have % or %% at the top-level */
[%bs.raw x => x];
[%%bs.raw x => x];
[%%randomExtension "with string payload"];
[%%randomExtension { with_obj: 33 }];
[%randomExtension { with_obj: 33 }];
/** with a comment on top */
[%%raw "console.log(42)"];
/* extensions live under expresions with only one % */
let f = [%bs.raw x => x];
/* https://github.com/facebook/reason/issues/2032 */
let predicate =
predicate === Functions.alwaysTrue1
? defaultPredicate
: fun%extend
| None => false
| Some(exn) => predicate(exn);
/* Attributes shoudn't be inlined and always break */
[@warning "-8"]
let a = 3;
[%%foo external x: int => int = ""];
[%%foo external x: int => int = "caml_prim"];
external%foo x: int => int = "caml_prim";
{%%M.foo| <hello>{x} |};
let x = {%M.foo bar| <hello>{|x|} |bar};
/* Double quotes inside quoted strings inside comments */
/* {|"|}, and */
/* [%foo {|"|}], and */
/* {%foo|"|} should be valid inside comments */
/* Comment delimiters inside quoted strings inside comments: */
/* {|*)|}, and */
/* [%foo {bar|*)|bar}], and */
/* {%foo bar|*)|bar} should be valid inside comments */
let x = [%raw {|"just raw"|}]
let y = [%raw {js|"raw js"|js}]
let z = [%raw {j|"raw j"|j}]
let x1 = {%raw |"just raw"|};
let y1 = {%raw js|"raw js"|js};
let z1 = {%raw j|"raw j"|j};
{%%raw |"just raw"|};
================================================
FILE: test/extensions.t/run.t
================================================
Format extensions
$ refmt ./input.re | tee formatted.re
/* Extension sugar */
[%extend open M];
[%extend module M = {}];
[%extend module type M = {}];
type a = [%extend int];
let%extend x = "hi";
let x = {
let%extend x = ();
ignore();
[%extend ignore()];
let%extend x = ();
[%extend return("hi")];
};
let x = {
if%extend (true) {1} else {2};
switch%extend (None) {
| Some(x) => assert(false)
| None => ()
};
try%extend(raise(Not_found)) {
| Not_found => ()
| Invalid_argument(msg) => prerr_endline(msg)
};
};
let x = {
if%extend (true) {1} else {2};
};
let x = {
switch%extend (None) {
| Some(x) => assert(false)
| None => ()
};
};
let x = {
try%extend(raise(Not_found)) {
| Not_found => ()
| Invalid_argument(msg) => prerr_endline(msg)
};
};
/* At structure level */
try%extend() {
| _ => ()
};
switch%extend () {
| _ => ()
};
if%extend (true) {1} else {2};
for%extend (i in 1 to 10) {
();
};
while%extend (false) {
();
};
[%extend () => ()];
fun%extend
| None => ()
| Some(1) => ();
/* In a top-level binding */
let x =
try%extend() {
| _ => ()
};
let x =
switch%extend () {
| _ => ()
};
let x = if%extend (true) {1} else {2};
let x =
for%extend (i in 1 to 10) {
();
};
let x =
while%extend (false) {
();
};
let x = [%extend () => ()];
let x =
fun%extend
| None => ()
| Some(1) => ();
/* With two extensions, alone */
let x = {
[%extend1
try%extend2() {
| _ => ()
}
];
};
let x = {
[%extend1
switch%extend2 () {
| _ => ()
}
];
};
let x = {
[%extend1 if%extend2 (true) {1} else {2}];
};
let x = {
[%extend1
for%extend2 (i in 1 to 10) {
();
}
];
};
let x = {
[%extend1
while%extend2 (false) {
();
}
];
};
let x = {
[%extend1 [%extend2 () => ()]];
};
let x = {
[%extend1
fun%extend2
| None => ()
| Some(1) => ()
];
};
/* With two extensions, first in sequence */
let x = {
[%extend1
try%extend2() {
| _ => ()
}
];
ignore();
};
let x = {
ignore();
[%extend1
switch%extend2 () {
| _ => ()
}
];
ignore();
};
let x = {
ignore();
[%extend1 if%extend2 (true) {1} else {2}];
ignore();
};
let x = {
ignore();
[%extend1
for%extend2 (i in 1 to 10) {
();
}
];
ignore();
};
let x = {
ignore();
[%extend1
while%extend2 (false) {
();
}
];
ignore();
};
let x = {
ignore();
[%extend1 [%extend2 () => ()]];
ignore();
};
let x = {
ignore();
[%extend1
fun%extend2
| None => ()
| Some(1) => ()
];
};
/* With two extensions, in sequence */
let x = {
ignore();
[%extend1
try%extend2() {
| _ => ()
}
];
ignore();
};
let x = {
ignore();
[%extend1
switch%extend2 () {
| _ => ()
}
];
ignore();
};
let x = {
ignore();
[%extend1 if%extend2 (true) {1} else {2}];
ignore();
};
let x = {
ignore();
[%extend1
for%extend2 (i in 1 to 10) {
();
}
];
ignore();
};
let x = {
ignore();
[%extend1
while%extend2 (false) {
();
}
];
ignore();
};
let x = {
ignore();
[%extend1 [%extend2 () => ()]];
ignore();
};
let x = {
ignore();
[%extend1
fun%extend2
| None => ()
| Some(1) => ()
];
ignore();
};
/* With two extensions, second in sequence */
let x = {
ignore();
[%extend1
try%extend2() {
| _ => ()
}
];
};
let x = {
ignore();
[%extend1
switch%extend2 () {
| _ => ()
}
];
};
let x = {
ignore();
[%extend1 if%extend2 (true) {1} else {2}];
};
let x = {
ignore();
[%extend1
for%extend2 (i in 1 to 10) {
();
}
];
};
let x = {
ignore();
[%extend1
while%extend2 (false) {
();
}
];
};
let x = {
ignore();
[%extend1 [%extend2 () => ()]];
};
let x = {
ignore();
[%extend1
fun%extend2
| None => ()
| Some(1) => ()
];
};
let _ =
switch%ext (expr) {
| A =>
/* Comment under A */
()
| B => ()
};
/* comments in presence of extension point syntax #1938 */
let () = {
/* 1. comment attached to extension */
[%defer
/* 2. comment attached to expr in extension */
cleanup()
];
/* 3. comment attached to next expr */
something_else();
};
/* comments in presence of extension point syntax #1938 */
let () = {
/* random let binding */
let x = 1;
/* 1. comment attached to extension */
[%defer
/* 2. comment attached to expr in extension */
cleanup()
];
/* 3. comment attached to next expr */
something_else();
};
let work = () => {
open Syntax;
let%bind name = x;
name;
};
/* Extensions can have % or %% at the top-level */
[%bs.raw x => x];
[%%bs.raw x => x];
[%%randomExtension "with string payload"];
[%%randomExtension { with_obj: 33 }];
[%randomExtension { with_obj: 33 }];
/** with a comment on top */
[%%raw "console.log(42)"];
/* extensions live under expresions with only one % */
let f = [%bs.raw x => x];
/* https://github.com/facebook/reason/issues/2032 */
let predicate =
predicate === Functions.alwaysTrue1
? defaultPredicate
: fun%extend
| None => false
| Some(exn) => predicate(exn);
/* Attributes shoudn't be inlined and always break */
[@warning "-8"]
let a = 3;
external%foo x: int => int;
external%foo x: int => int = "caml_prim";
external%foo x: int => int = "caml_prim";
{%%M.foo | <hello>{x} |};
let x = {%M.foo bar| <hello>{|x|} |bar};
/* Double quotes inside quoted strings inside comments */
/* {|"|}, and */
/* [%foo {|"|}], and */
/* {%foo|"|} should be valid inside comments */
/* Comment delimiters inside quoted strings inside comments: */
/* {|*)|}, and */
/* [%foo {bar|*)|bar}], and */
/* {%foo bar|*)|bar} should be valid inside comments */
let x = [%raw {|"just raw"|}];
let y = [%raw {js|"raw js"|js}];
let z = [%raw {j|"raw j"|j}];
let x1 = {%raw |"just raw"|};
let y1 = {%raw js|"raw js"|js};
let z1 = {%raw j|"raw j"|j};
{%%raw |"just raw"|};
Format the formatted file back
$ refmt --print re ./formatted.re > ./formatted_back.re
Ensure idempotency: first format and second format are the same
$ diff formatted.re formatted_back.re
================================================
FILE: test/externals.t/input.re
================================================
/**
* Tests external formatting.
*/
external foo : type_ = "%caml_something_or_other";
external multilineStringExtern : int => int = {|
Did you know you can put whatver you want inside
of an extern? Good luck with the linker though!
|};
module Nested = {
external multilineStringExtern : int => int = {|
Did you know you can put whatver you want inside
of an extern? Good luck with the linker though!
|};
external multilineStringExternWithTag : int => int = {js|
Did you know you can put whatver you want inside
of an extern? Good luck with the linker though!
|js};
external multilineStringExtern : int => int = "
And this has a newline in it, so will be formatted with { | | } style string";
external containsQuote : int => int = "This has a quote in it \" so will be formatted as { | | } style string";
external noIndentation : int => int = {|
Did you know you can put whatver you want inside
of an extern? Good luck with the linker though!
|};
};
================================================
FILE: test/externals.t/run.t
================================================
Format externals
$ refmt ./input.re
/**
* Tests external formatting.
*/
external foo: type_ = "%caml_something_or_other";
external multilineStringExtern: int => int =
{|
Did you know you can put whatver you want inside
of an extern? Good luck with the linker though!
|};
module Nested = {
external multilineStringExtern: int => int =
{|
Did you know you can put whatver you want inside
of an extern? Good luck with the linker though!
|};
external multilineStringExternWithTag:
int => int =
{|
Did you know you can put whatver you want inside
of an extern? Good luck with the linker though!
|};
external multilineStringExtern: int => int =
{|
And this has a newline in it, so will be formatted with { | | } style string|};
external containsQuote: int => int =
{|This has a quote in it " so will be formatted as { | | } style string|};
external noIndentation: int => int =
{|
Did you know you can put whatver you want inside
of an extern? Good luck with the linker though!
|};
};
================================================
FILE: test/fdLeak.t/input.re
================================================
let () =
let x = 1 in
Format.eprintf "X: %d@." x
================================================
FILE: test/fdLeak.t/run.t
================================================
$ ulimit -n 24
$ ../lib/fdLeak.exe
EOL: done
================================================
FILE: test/firstClassModules.t/input.re
================================================
module Modifier = (val ((Db.Hashtbl.create ()): (module Db.Sig with type t = Mods.t)));
module Modifier = (val (Db.Hashtbl.create ()): (Db.Sig with type t = Mods.t));
module Modifier = (val (Db.Hashtbl.create (): module Db.Sig with type t = Mods.t));
module Modifier = (val Db.Hashtbl.create (): Db.Sig with type t = Mods.t);
module Modifier = (val Db.Hashtbl.create ());
module Modifier = (val Db.Hashtbl.create ():
Db.Sig with type t = Mods.t and type s = Mods.s and
type z = Mods.z);
module Lowercase = (val stuff: lowercase);
module Lowercase = (val stuff: Foo.Bar.lowercase);
module Lowercase = (val stuff: Foo.Bar.lowercase with type t = Mods.t);
module T = (val (module FirstClass): myLowercaseModule);
module Three = (val three: X_int);
let thing: module Thing = (module MyModule);
let thing: module Foo.Bar.Thing = (module MyModule);
let smallThing: (module lowercase) = (module Mod);
let smallThing: module lowercase = (module Mod);
let smallThing: (module Foo.Bar.lowercase) = (module Mod);
let smallThing: module Foo.Bar.lowercase = (module Mod);
let f = ((module Add : S.Z), x) => Add.add(x);
let join_iter =
(type ta, type tb,
((module A): (module Sig with type t=ta)),
(module B): (module Sig with type t=tb),
module C: module Sig with type t=tb,
module D: Sig with type t=tb and type s =tc and type x = td and type z = te,
fn) => fn(A.value + B.value);
type t = ref((module Console));
type firstClassConsole = (module Console);
type crossPlatform = Platform.t((module Windows), (module Mac), (module Linux));
type t = (module FirstClass, module SecondClass);
type withAttr = ref([@bar] (module Console));
type withAttrPlatform = Platform.t([@bar] (module Iphone), [@foo] (module Ipad));
type tWithAttr = ([@foo] (module FirstClass), [@bar] (module SecondClass));
type t = {m: (module M)};
/* https://github.com/facebook/reason/issues/2150 */
type t('a) = (module Test with type a = 'a);
================================================
FILE: test/firstClassModules.t/run.t
================================================
Format first class modules
$ refmt ./input.re
module Modifier = (
val Db.Hashtbl.create():
Db.Sig with type t = Mods.t
);
module Modifier = (
val Db.Hashtbl.create():
Db.Sig with type t = Mods.t
);
module Modifier = (
val Db.Hashtbl.create():
Db.Sig with type t = Mods.t
);
module Modifier = (
val Db.Hashtbl.create():
Db.Sig with type t = Mods.t
);
module Modifier = (val Db.Hashtbl.create());
module Modifier = (
val Db.Hashtbl.create():
Db.Sig with
type t = Mods.t and
type s = Mods.s and
type z = Mods.z
);
module Lowercase = (val stuff: lowercase);
module Lowercase = (
val stuff: Foo.Bar.lowercase
);
module Lowercase = (
val stuff:
Foo.Bar.lowercase with type t = Mods.t
);
module T = (
val (module FirstClass): myLowercaseModule
);
module Three = (val three: X_int);
let thing: (module Thing) = (module MyModule);
let thing: (module Foo.Bar.Thing) =
(module MyModule);
let smallThing: (module lowercase) =
(module Mod);
let smallThing: (module lowercase) =
(module Mod);
let smallThing: (module Foo.Bar.lowercase) =
(module Mod);
let smallThing: (module Foo.Bar.lowercase) =
(module Mod);
let f = (module Add: S.Z, x) => Add.add(x);
let join_iter =
(
type ta,
type tb,
module A: Sig with type t = ta,
module B: Sig with type t = tb,
module C: Sig with type t = tb,
module D:
Sig with
type t = tb and
type s = tc and
type x = td and
type z = te,
fn,
) =>
fn(A.value + B.value);
type t = ref(module Console);
type firstClassConsole = (module Console);
type crossPlatform =
Platform.t(
module Windows,
module Mac,
module Linux,
);
type t = (
module FirstClass,
module SecondClass,
);
type withAttr = ref([@bar] (module Console));
type withAttrPlatform =
Platform.t(
[@bar] (module Iphone),
[@foo] (module Ipad),
);
type tWithAttr = (
[@foo] (module FirstClass),
[@bar] (module SecondClass),
);
type t = {m: (module M)};
/* https://github.com/facebook/reason/issues/2150 */
type t('a) = (module Test with type a = 'a);
================================================
FILE: test/fixme.t/input.re
================================================
/**
* Problem: In thise example, the comment should have a space after it.
*/
let store_attributes(proc_attributes) {
let should_write =
/* only overwrite defined procedures */proc_attributes.ProcAttributes.is_defined ||
not (DB.file_exists(attributes_file));
should_write;
};
================================================
FILE: test/fixme.t/run.t
================================================
Format fixme
$ refmt ./input.re
/**
* Problem: In thise example, the comment should have a space after it.
*/
let store_attributes = proc_attributes => {
let should_write =
/* only overwrite defined procedures */ proc_attributes.ProcAttributes.is_defined
|| not(DB.file_exists(attributes_file));
should_write;
};
================================================
FILE: test/functionInfix.t/input.re
================================================
let entries = ref([]);
let all = ref(0);
/*
* >>= is left associative, and higher precedence than =>
*/
let (>>=)(a,b) = b(a);
let fff = ();
/** Parse tree */
(fff >>= (xx(yy) >>= aa(bb)));
/* Minimum parenthesis */
fff >>= xx(yy) >>= aa(bb);
/* Actually printed parenthesis */
fff >>= (xx(yy) >>= aa(bb));
/** Parse tree */
fff >>= ((fun(xx)=> 0) >>= (fun(aa) => 10));
/* Minimum parenthesis */
fff >>= ((fun(xx)=> 0) >>= (fun(aa) => 10));
/* Actually printed parenthesis */
fff >>= ((fun(xx)=> 0) >>= (fun(aa) => 10));
/** Parse tree */
((fff >>= (fun(xx) => 0)) >>= (fun(aa) => 10));
/* Minimum parenthesis */
/* It is very difficult to actually achieve this. */
fff >>= (fun(xx) => 0) >>= fun(aa) => 10;
/* Actually printed. */
fff >>= (fun(xx) => 0) >>= (fun(aa) => 10);
/** Parse tree */
(fff >>= (fun(xx) => (0 >>= (fun(aa,cc) => 10))));
/* Minimum parens - grouping the zero */
/* Difficult to achieve. */
fff >>= fun(xx) => 0 >>= (fun(aa,cc) => 10);
/* Actually printed parenthesis. */
fff >>= (fun(xx) => 0) >>= (fun(aa,cc) => 10);
/* Another way you could also write it it */
(fff >>= fun(xx) => 0) >>= (fun(aa,cc) => 10);
/** Parse tree */
(fff >>= (fun(xx) => 0));
/* Minimum parens - grouping the zero */
fff >>= fun(xx) => 0;
/* Printed parens - see how more are printed than necessary. */
fff >>= (fun(xx) => 0);
================================================
FILE: test/functionInfix.t/run.t
================================================
Format function infix
$ refmt ./input.re
let entries = ref([]);
let all = ref(0);
/*
* >>= is left associative, and higher precedence than =>
*/
let (>>=) = (a, b) => b(a);
let fff = ();
/** Parse tree */
fff >>= (xx(yy) >>= aa(bb));
/* Minimum parenthesis */
fff >>= xx(yy) >>= aa(bb);
/* Actually printed parenthesis */
fff >>= (xx(yy) >>= aa(bb));
/** Parse tree */
fff >>= ((xx => 0) >>= (aa => 10));
/* Minimum parenthesis */
fff >>= ((xx => 0) >>= (aa => 10));
/* Actually printed parenthesis */
fff >>= ((xx => 0) >>= (aa => 10));
/** Parse tree */
fff >>= (xx => 0) >>= (aa => 10);
/* Minimum parenthesis */
/* It is very difficult to actually achieve this. */
fff >>= (xx => 0) >>= (aa => 10);
/* Actually printed. */
fff >>= (xx => 0) >>= (aa => 10);
/** Parse tree */
fff >>= (xx => 0 >>= ((aa, cc) => 10));
/* Minimum parens - grouping the zero */
/* Difficult to achieve. */
fff >>= (xx => 0 >>= ((aa, cc) => 10));
/* Actually printed parenthesis. */
fff >>= (xx => 0) >>= ((aa, cc) => 10);
/* Another way you could also write it it */
fff >>= (xx => 0) >>= ((aa, cc) => 10);
/** Parse tree */
fff >>= (xx => 0);
/* Minimum parens - grouping the zero */
fff >>= (xx => 0);
/* Printed parens - see how more are printed than necessary. */
fff >>= (xx => 0);
================================================
FILE: test/general-syntax-re.t/input.re
================================================
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
[@autoFormat let wrap=80; let shift=2;];
Modules.run ();
Polymorphism.run ();
Variants.run();
BasicStructures.run();
TestUtils.printSection("General Syntax");
/* Won't work! */
/* let matchingFunc a = match a with */
/* `Thingy x => (print_string "matched thingy x"); x */
/* | `Other x => (print_string "matched other x"); x;; */
/* */
let matchingFunc(a) = switch (a) {
| `Thingy x => {
print_string("matched thingy x");
let zz = 10;
zz;
}
| `Other x => {
print_string("matched other x");
x;
}
};
type firstTwoShouldBeGroupedInParens =
((int) => int, int) => int;
type allParensCanBeRemoved =
(int) => ((int) => ((int) => int));
type firstTwoShouldBeGroupedAndFirstThree =
(((int) => int) => int) => int;
/* Same thing now but with type constructors instead of each int */
type firstTwoShouldBeGroupedInParens =
((list(int)) => list(int), list(int)) => list(int);
type allParensCanBeRemoved =
(list(int)) => ((list(int)) => ((list(int)) => list(int)));
type firstTwoShouldBeGroupedAndFirstThree =
(((list(int)) => list(int)) => list(int)) => list(int);
type myRecordType = {
firstTwoShouldBeGroupedInParens:
((int) => int, int) => int,
allParensCanBeRemoved:
(int) => ((int) => ((int) => int)),
firstTwoShouldBeGroupedAndFirstThree:
(((int) => int) => int) => int,
};
type firstNamedArgShouldBeGroupedInParens =
(~first: (int) => int, ~second: int) => int;
type allParensCanBeRemoved =
(~first: int) => ((~second: int) => ((~third: int) => int));
type firstTwoShouldBeGroupedAndFirstThree =
(~first: ((int) => int) => int) => int;
/* Same thing now, but with type constructors instead of int */
type firstNamedArgShouldBeGroupedInParens =
(~first: (list(int)) => list(int)) => (~second: list(int)) => list(int);
type allParensCanBeRemoved =
(~first: list(int)) => (~second: list(int)) => (~third: list(int)) => list(int);
type firstTwoShouldBeGroupedAndFirstThree =
(~first: ((list(int)) => list(int)) => list(int)) => list(int);
type firstNamedArgShouldBeGroupedInParens =
(~first: ((int) => int)=?, ~second: list(int)=?) => int;
/* The arrow necessitates parens around the next two args. The ? isn't what
* makes the parens necessary. */
type firstNamedArgShouldBeGroupedInParensAndSecondNamedArg =
(~first: ((int) => int)=?, ~second: ((int) => int)=?) => int;
type allParensCanBeRemoved =
(~first: int=?, ~second: int=?, ~third: int=?) => int;
type firstTwoShouldBeGroupedAndFirstThree =
(~first: (((int) => int) => int)) => int;
type noParens = (~one: int, int, int, ~two: int) => int;
type noParensNeeded = (~one: int) => ((int) => ((int) => ((~two: int) => int)));
type firstNamedArgNeedsParens = (~one: (int, int) => int, ~two: int) => int;
/* Now, let's try type aliasing */
/* Unless wrapped in parens, types between arrows may not be aliased, may not
* themselves be arrows. */
type parensRequiredAroundFirstArg = (list(int) as 'a) => int as 'a;
type parensRequiredAroundReturnType = (list(int) as 'a) => (int as 'a);
type parensRequiredAroundReturnType = (list(int) as 'a) => (int as 'a) as 'b;
type noParensNeededWhenInTuple = (list(int) as 'a, list(int) as 'b) as 'entireThing;
type myTypeDef('a) = list('a);
type instatiatedTypeDef = (myTypeDef(int)) => int;
/* Test a type attribute for good measure */
/* We should clean up all of the attribute tagging eventually, but for now,
* let's make it super ugly to get out of the way of all the formatting/parsing
* implementations (fewer conflicts during parsing, fewer edge cases during
* printing).
*/
type something = (int, ([@lookAtThisAttribute] int));
type longWrappingTypeDefinitionExample =
M_RK__G.Types.instance (
TGRecognizer.tGFields(unit,unit),
TGRecognizer.tGMethods(unit,unit)
)
;
type semiLongWrappingTypeDefinitionExample =
M_RK__Gesture.Types.instance (
TGRecognizerFinal.tGFields,
TGRecognizerFinal.tGMethods
);
type semiLongWrappingTypeWithConstraint =
M_RK__Gesture.Types.instance('a,
TGRecognizerFinal.tGFields,
TGRecognizerFinal.tGMethods
) constraint 'a = (unit, unit)
;
type onelineConstrain = 'a constraint 'a = int;
/* This must be in trunk but not in this branch of OCaml */
/* type withNestedRecords = MyConstructor {myField: int} */
type colors =
| Red(int)
| Black(int)
| Green(int);
/* Another approach is to require declared variants to wrap any record */
/* type myRecord = MyRecord {name: int}; */
/* let myValue = MyRecord {name: int}; */
/* This would force importing of the module */
/* This would also lend itself naturally to pattern matching - and avoid having
to use `.` operator at all since you normally destructure. */
type nameBlahType = {nameBlah: int};
let myRecord = {nameBlah: 20};
let myRecordName = myRecord.nameBlah;
let {nameBlah}:nameBlahType = {nameBlah: 20};
print_int(nameBlah);
let {nameBlah: aliasedToThisVar}:nameBlahType = {nameBlah: 20};
print_int(aliasedToThisVar);
let desiredFormattingForWrappedLambda:
(int, int, int) => nameBlahType =
/*
fun is
pre- /firstarg\
fix /-coupled--\
|-\ /-to-prefix--\ */
fun(curriedArg,
anotherArg,
lastArg) => {
nameBlah: 10
};
type longerInt = int;
let desiredFormattingForWrappedLambdaWrappedArrow:
(longerInt,
longerInt,
longerInt) =>
nameBlahType =
/*
fun is
pre- /firstarg\
fix /-coupled--\
|-\ /-to-prefix--\ */
fun(curriedArg,
anotherArg,
lastArg) => {
nameBlah: 10
};
let desiredFormattingForWrappedLambdaReturnOnNewLine =
/*
fun is
pre- /firstarg\
fix /-coupled--\
|-\ /-to-prefix--\ */
fun(curriedArg,
anotherArg,
lastArg) =>
{
nameBlah: 10
};
/*
let is
pre-
fix /-function binding name---\
|-\ / is coupled to prefix \ */
let desiredFormattingForWrappedSugar
(curriedArg,
anotherArg,
lastArg) {
nameBlah: 10
};
/*
let is
pre-
fix /-function binding name---\
|-\ / is coupled to prefix \ */
let desiredFormattingForWrappedSugarReturnOnNewLine
(curriedArg,
anotherArg,
lastArg)
{
nameBlah: 10
};
/*
let : type t1 t2. t1 * t2 list -> t1 = ...
let rec f : 't1 't2. 't1 * 't2 list -> 't1 =
fun (type t1) (type t2) -> (... : t1 * t2 list -> t1)
*/
type point = {x: int, y:int};
type point3D = {x: int, y:int, z:int};
let point2D = {
x: 20,
y: 30
};
let point3D:point3D = {
x: 10,
y: 11,
z: 80, /* Optional Comma */
};
let printPoint (p:point) {
print_int(p.x);
print_int(p.y);
};
let addPoints (p1:point, p2:point) {
x: p1.x + p2.x,
y: p1.y + p2.y
};
let res1 = printPoint(point2D);
let res2 = printPoint({x:point3D.x, y:point3D.y});
/*
When () were used to indicate sequences, the parser used seq_expr not only
for grouping sequences, but also to form standard precedences.
/------- sequence_expr ------\
let res3 = printPoint (addPoints (point2D, point3D));
Interestingly, it knew that tuples aren't sequences.
To move towards semi delimited, semi-terminated, braces-grouped sequences:
while allowing any non-sequence expression to be grouped on parens, we make
an explicit rule that allows one single non-semi ended expression to be
grouped in parens.
Actually: We will allow an arbitrary number of semi-delimited expressions to
be wrapped in parens, but the braces grouped semi delimited (sequence)
expressions must *also* be terminated with a semicolon.
This allows the parser to distinguish between
let x = {a}; /* Record {a:a} */
let x = {a;}; /* Single item sequence returning identifier {a} */
*/
let res3 = printPoint (addPoints (point2D, {x:point3D.x, y:point3D.y}));
type person = {age: int, name: string};
type hiredPerson = {age: string, name: string, dateHired: int};
let o: (person) = {name: "bob", age: 10};
/* Parens needed? Nope! */
let o: person = {name: "bob", age: 10};
let printPerson (p: person) {
let q: person = p;
p.name ++ p.name;
};
/* let dontParseMeBro x y:int = x = y;*/
/* With this unification, anywhere eyou see `= fun` you can just ommit it */
let blah = fun(a) => a; /* Done */
let blah (a) = a; /* Done (almost) */
let blah = fun(a,b) => a; /* Done */
let blah (a, b) = a; /* Done (almost) */
/* More than one consecutive pattern must have a single case */
type blah = {blahBlah: int};
let blah = fun (a, {blahBlah}) => a;
let blah (a, {blahBlah}) = a;
module TryToExportTwice = {
let myVal = "hello";
};
/*
Unifying top level module syntax with local module syntax is probably a bad
idea at the moment because it makes it more difficult to continue to support
`let .. in` bindings. We can distinguish local modules for `let..in` that
just happen to be defined at the top level (but not exported).
let MyModule = {let myVal = 20;} in
MyModule.x
Wait, where would this ever be valid, even if we continued to support
`let..in`?
*/
let onlyDoingThisTopLevelLetToBypassTopLevelSequence = {
let x = {
print_int(1);
print_int(20); /* Missing trailing SEMI */
};
let x = {
print_int(1);
print_int(20); /* Ensure missing middle SEMI reported well */
print_int(20);
};
let x = {
print_int(1);
print_int(20);
10;
/* Comment in final position */
}; /* Missing final SEMI */
x + x;
};
type hasA = {a:int};
let a = 10;
let returnsASequenceExpressionWithASingleIdentifier () {a};
let thisReturnsA () {a;};
let thisReturnsAAsWell () = a;
let recordVal:int = thisReturnsARecord().a;
Printf.printf("\nproof that thisReturnsARecord: %n\n", recordVal);
Printf.printf("\nproof that thisReturnsA: %n\n", thisReturnsA());
/* Pattern matching */
let blah = fun(arg) => switch (arg) {
/* Comment before Bar */
| /* Comment between bar/pattern */
Red(_) => 1
/* Comment Before non-first bar */
| /* Comment betwen bar/pattern */
Black(_) => 0
| Green(_) => 0
};
/* Any function that pattern matches a multicase match is interpretted as a
* single arg that is then matched on. Instead of the above `blah` example:*/
let blah = fun
| Red(_) => 1
| Black(_) => 0
| Green(_) => 1;
/* `fun a => a` is read as "a function that maps a to a". Then the */
/* above example is read: "a function that 'either maps' Red to.. or maps .." */
/* Thc00f564e first bar is read as "either maps" */
/* Curried form is not supported:
let blah x | Red _ => 1 | Black _ => 0;
Theres no sugar rule for dropping => fun, only = fun
*/
/* let blahCurriedX x => fun /* See, nothing says we can drop the => fun */ */
/* |(Red x | Black x | Green x) => 1 /* With some effort, we can ammend the sugar rule that would */ */
/* | Black x => 0 /* Allow us to drop any => fun.. Just need to make pattern matching */ */
/* | Green x => 0; /* Support that */ */
/* */
let blahCurriedX(x) =
fun
| Red(x)
| Black(x)
| Green(x) => 1 /* With some effort, we can ammend the sugar rule that would */
| Black(x) => 0 /* Allow us to drop any => fun.. Just need to make pattern matching */
| Green(x) => 0; /* Support that */
let sameThingInLocal = {
let blahCurriedX(x) =
fun
| Red(x)
| Black(x)
| Green(x) => 1 /* With some effort, we can ammend the sugar rule that would */
| Black(x) => 0 /* Allow us to drop any => fun.. Just need to make pattern matching */
| Green(x) => 0; /* Support that */
blahCurriedX;
};
/* This should be parsed/printed exactly as the previous */
let blahCurriedX(x) = fun
| Red(x) | Black(x) | Green(x) => 1
| Black(x) => 0
| Green(x) => 0;
/* Any time there are multiple match cases we require a leading BAR */
let v = Red(10);
let (Black(x) | Red(x) | Green(x)) = v; /* So this NON-function still parses */
/* This doesn't parse, however (and it doesn't in OCaml either):
let | Black(x) | Red(x) | Green(x) = v;
*/
print_int(x);
/* Scoping: Let sequences. Familiar syntax for lexical ML style scope and
sequences. */
let res = {
let a = "a starts out as";
{
print_string(a);
let a = 20;
print_int(a);
};
print_string(a);
};
let res = {
let a = "first its a string";
let a = 20;
print_int(a);
print_int(a);
print_int(a);
};
let res = {
let a = "a is always a string";
print_string(a);
let b = 30;
print_int(b);
};
/* let result = LyList.map((fun | [] => true | _ => false), []); */
/* OTHERWISE: You cannot tell if a is the first match case falling through or
* a curried first arg */
/* let blah = fun a | patt => 0 | anotherPatt => 1; */
/* let blah a patt => 0 | anotherPatt => 1; */
/*simple pattern EQUALGREATER expr */
let blah ( a, {blahBlah}) = a;
/* match_case */
/* pattern EQUALGREATER expr */
let blah = fun |Red(_) => 1 |Black(_)=> 0 |Green(_)=> 0;
/* Won't work! */
/* let arrowFunc = fun a b => print_string "returning aplusb from arrow"; a + b;; */
let arrowFunc = fun(a,b)=> {print_string("returning aplusb from arrow"); a + b;};
let add(a,b) {
let extra = {print_string("adding"); 0;};
let anotherExtra = 0;
extra + a + b + anotherExtra;
};
(print_string (string_of_int (add(4,34))));
let dummy(_) = 10;
dummy(res1);
dummy(res2);
dummy(res3);
/* Some edge cases */
let myFun (firstArg, Red(x) | Black(x) | Green(x)) = firstArg + x;
let matchesWithWhen(a) = switch (a) {
| Red(x) when 1 > 0 => 10
| Red(_) => 10
| Black(x) => 10
| Green(x) => 10
};
let matchesWithWhen = fun
| Red(x) when 1 > 0 => 10
| Red(_) => 10
| Black(x) => 10
| Green(x) => 10;
let matchesOne (`Red x) = 10;
/*
Typical OCaml would make you *wrap the functions in parens*! This is because it
can't tell if a semicolon is a sequence operator. Even if we had records use
commas to separate fields,
*/
type adders = {
addTwoNumbers: (int, int) => int,
addThreeNumbers: (int, int, int) => int,
addThreeNumbersTupled: ((int, int, int)) => int
};
let myRecordWithFunctions = {
addTwoNumbers: (a,b) => a + b,
addThreeNumbers: (a,b,c) => a + b + c,
addThreeNumbersTupled: ((a, b, c)) => a + b + c
};
let result = myRecordWithFunctions.addThreeNumbers(10, 20, 30);
let result = myRecordWithFunctions.addThreeNumbersTupled((10, 20, 30));
let lookTuplesRequireParens = (1, 2);
/* let thisDoesntParse = 1, 2; */
let tupleInsideAParenSequence = {
print_string("look, a tuple inside a sequence");
let x = 10;
(x, x);
};
let tupleInsideALetSequence = {
print_string("look, a tuple inside a sequence");
let x = 10;
(x, x);
};
/* We *require* that function return types be wrapped in
parenthesis. In this example, there's no ambiguity */
let makeIncrementer (delta:int) : (int)=>int = (a) => a + delta;
/* We could even force that consistency with let bindings - it's allowed
currently but not forced.
*/
let (myAnnotatedValBinding:int) = 10;
/* Class functions (constructors) and methods are unified in the same way */
class classWithNoArg {
pub x = 0;
pub y = 0;
};
/* This parses but doesn't type check
class myClass init => object
pub x => init
pub y => init
end;
*/
let myFunc (a:int, b:int) : (int, int) = (a, b);
let myFunc (a:int, b:int) : list(int) = [1];
let myFunc (a:int, b:int) : point {
x: a,
y: b
};
let myFunc (a:int, b:int) : point {
x: a,
y: b
};
type myThing = (int, int);
type stillARecord = {name: string, age: int};
/* Rebase latest OCaml to get the following: And fixup
`generalized_constructor_arguments` according to master. */
/* type ('a, 'b) myOtherThing = Leaf {first:'a, second: 'b} | Null; */
type branch('a,'b) = {first: 'a, second: 'b};
type myOtherThing('a,'b) = Leaf (branch('a,'b)) | Null;
type yourThing = myOtherThing(int,int);
/* Conveniently - this parses exactly how you would intend! No *need* to wrap
in an extra [], but it doesn't hurt */
/* FIXME type lookAtThesePolyVariants = list [`Red] ; */
/* FIXME type bracketsGroupMultipleParamsAndPrecedence = list (list (list [`Red])); */
/* FIXME type youCanWrapExtraIfYouWant = (list [`Red]); */
/* FIXME type hereAreMultiplePolyVariants = list [`Red | `Black]; */
/* FIXME type hereAreMultiplePolyVariantsWithOptionalWrapping = list ([`Red | `Black]); */
/*
/* Proposal: ES6 style lambdas: */
/* Currying */
let lookES6Style = (`Red x) (`Black y) => { };
let lookES6Style (`Red x) (`Black y) => { };
/* Matching the single argument */
let lookES6Style = oneArg => match oneArg with
| `Red x => x
| `Black x => x;
/* The "trick" to currying that we already have is basically the same - we just
* have to reword it a bit:
* From:
* "Any time you see [let x = fun ...] just replace it with [let x ...]"
* To:
* "Any time you see [let x = ... => ] just replace it with [let x ... => ]"
*/
let lookES6Style oneArg => match oneArg with
| `Red x => x
| `Black x => x;
*/
/** Current OCaml Named Arguments. Any aliasing is more than just aliasing!
OCaml allows full on pattern matching of named args. */
/*
A: let named ~a ~b = aa + bb in
B: let namedAlias ~a:aa ~b:bb = aa + bb in
C: let namedAnnot ~(a:int) ~(b:int) = a + b in
D: let namedAliasAnnot ~a:(aa:int) ~b:(bb:int) = aa + bb in
E: let optional ?a ?b = 10 in
F: let optionalAlias ?a:aa ?b:bb = 10 in
G: let optionalAnnot ?(a:int option) ?(b:int option) = 10 in
H: let optionalAliasAnnot ?a:(aa:int option) ?b:(bb:int option) = 10 in
/*
Look! When a default is provided, annotation causes inferred type of argument
to not be "option" since it's automatically destructured (because we know it
will always be available one way or another.)
*/
I: let defOptional ?(a=10) ?(b=10) = 10 in
J: let defOptionalAlias ?a:(aa=10) ?b:(bb=10) = 10 in
K: let defOptionalAnnot ?(a:int=10) ?(b:int=10) = 10 in
\ \
\label_let_pattern opt_default: no longer needed in SugarML
L: let defOptionalAliasAnnot ?a:(aa:int=10) ?b:(bb:int=10) = 10 in
\ \
\let_pattern: still a useful syntactic building block in SugarML
*/
/**
* In Reason, the syntax for named args uses double semicolon, since
* the syntax for lists uses ES6 style [], freeing up the ::.
*/
let a = 10;
let b = 20;
/*A*/
let named (~a as a, ~b as b) = a + b;
type named = (~a: int, ~b: int) => int;
/*B*/
let namedAlias (~a as aa, ~b as bb) = aa + bb;
let namedAlias (~a as aa, ~b as bb) = aa + bb;
type namedAlias = (~a: int, ~b: int) => int;
/*C*/
let namedAnnot (~a :int, ~b :int) = 20;
/*D*/
let namedAliasAnnot (~a as aa:int,~b as bb:int) = 20;
/*E*/
let myOptional (~a=?, ~b=?, ()) = 10;
type named = (~a: int=?, ~b: int=?, unit) => int;
/*F*/
let optionalAlias (~a as aa=?, ~b as bb=?, ()) = 10;
/*G*/
let optionalAnnot (~a as a:int =?, ~b as b:int=?, ()) = 10;
/*H*/
let optionalAliasAnnot (~a as aa:int =?, ~b as bb:int=?, ()) = 10;
/*I: */
let defOptional (~a as a=10, ~b as b=10, ()) = 10;
type named = (~a: int=?, ~b: int=?, unit) => int;
/*J*/
let defOptionalAlias (~a as aa=10, ~b as bb=10, ()) = 10;
/*K*/
let defOptionalAnnot (~a as a:int=10, ~b as b:int=10, ()) = 10;
/*L*/
let defOptionalAliasAnnot(~a as aa:int=10, ~b as bb:int=10, ()) = 10;
/*M: Invoking them - Punned */
let resNotAnnotated = named(~a=a,~b=b);
/*N:*/
let resAnnotated = (named(~a=a,~b=b):int);
/*O: Invoking them */
let resNotAnnotated = named(~a=a,~b=b);
/*P: Invoking them */
let resAnnotated = (named(~a=a,~b=b):int);
/*Q: Here's why "punning" doesn't work! */
/* Is b:: punned with a final non-named arg, or is b:: supplied b as one named arg? */
let b = 20;
let resAnnotated = (named(~a=a,~b=b));
/*R: Proof that there are no ambiguities with return values being annotated */
let resAnnotated = (named(~a=a,b):ty);
/*S: Explicitly passed optionals are a nice way to say "use the default value"*/
let explictlyPassed = myOptional(~a=?None,~b=?None);
/*T: Annotating the return value of the entire function call */
let explictlyPassedAnnotated = (myOptional(~a=?None,~b=?None):int);
/*U: Explicitly passing optional with identifier expression */
let a = None;
let explictlyPassed = myOptional(~a=?a,~b=?None);
let explictlyPassedAnnotated = (myOptional(~a=?a,~b=?None):int);
let nestedLet = {
let _ = 1
};
let nestedLet = {
let _ = 1;
};
let nestedLet = {
let _ = 1;
()
};
let nestedLet = {
let _ = 1;
2
};
/*
* Showing many combinations of type annotations and named arguments.
*/
type typeWithNestedNamedArgs =
(~outerOne: (~innerOne: int, ~innerTwo: int) => int, ~outerTwo: int) => int;
type typeWithNestedOptionalNamedArgs =
(~outerOne: (~innerOne: int, ~innerTwo: int) => int=?, ~outerTwo: int=?) => int;
type typeWithNestedOptionalNamedArgs =
(~outerOne: list(string)=?, ~outerTwo: int=?) => int;
let f(~tuple="long string to trigger line break") = ();
let x =
callSomeFunction
(~withArg=10,
~andOtherArg=wrappedArg);
let res = {
(constraintedSequenceItem:string);
(dontKnowWheYoudWantToActuallyDoThis:string);
};
let res = {
(butTheyWillBePrintedWithAppropriateSpacing : string);
(soAsToInstillBestDevelopmentPractices : string);
};
let x = [
eachItemInListCanBeAnnotated:int,
typeConstraints:float,
(tupleConstraints:int, andNotFunctionInvocations:int)
];
let x = [
butWeWillPrint : int,
themAsSpaceSeparated : float,
(toInfluenceYour : int, developmentHabbits : int)
];
let newRecord = {
...annotatedSpreadRecord:someRec,
x: y
};
let newRecord = {
...annotatedSpreadRecord : someRec,
blah: 0,
foo: 1
};
let newRecord = {
...youCanEvenCallMethodsHereAndAnnotate(them): someRec,
blah: 0,
foo: 1
};
let newRecord = {
...youCanEvenCallMethodsHereAndAnnotate(them,~named=10):someRec,
blah: 0,
foo: 1
};
let something = (aTypeAnnotation : thing(blah));
let something = (thisIsANamedArg: thing(blah));
let something = (aTypeAnnotation: thing(blah));
let something = (thisIsANamedArg(thing):blah);
let something = (typeAnnotation(thing): blah);
let newRecord = {
...(heresAFunctionWithNamedArgs(~argOne=i) :annotatedResult),
soAsToInstill: 0,
developmentHabbits: 1
};
[@thisIsAThing];
let x = 10;
/* Ensure that the parenthesis are preserved here because they are
* important:
*/
let something =
fun | None => (fun | [] => "emptyList" | [_, ..._] => "nonEmptyList")
| Some(_)=> (fun | [] => "emptyList" | [_, ..._] => "nonEmptyList");
/* A | B = X; */
let A | B = X;
/* A | (B | C) = X; */
let A | (B | C) = X;
/* (A | B) | (C | D) = X; */
let (A | B) | (C | D) = X;
/* A | B | (C | D) = X; */
let A | B | (C | D) = X;
/* (A | B) | C = X; */
let (A | B) | C = X;
/* A | B | C = X; */
let A | B | C = X;
/** External function declaration
*
*/
external f : (int) => int = "foo";
let x = {contents: 0};
let unitVal = x.contents = 210;
let match = "match";
let method = "method";
let foo(x,~x as bar,~z,~foo as bar,~foo as z) {
bar + 2
};
let zzz = myFunc(1, 2, [||]);
/* 1492 */
let registerEventHandlers =
(
~window: Window.t,
~mouseDown:
option(((~button: Events.buttonStateT, ~state: Events.stateT, ~x: int, ~y: int) => unit))=?,
()
) => 1;
/* #1320: record destrucuring + renaming */
let x = ({state: state as prevState}) => 1;
let x = ({ReasonReact.state: state as prevState}) => 1;
/* 1567: optional parens around expr constraint in constructor expression */
Some(x : int);
Some((x : int));
Some(x, y: int, b);
Some(x, (y: int), b);
foo(~x=-. bar);
Some((-1), (-1), (-1));
Some(-1, -1, -1);
Some(-1g, -1G, -1z);
Some((-1g), (-1G), (-1z));
Some(-0.1, -0.1, -0.1);
Some((-0.1), (-0.1), (-0.1));
Some(-0.1G, -0.1x, -0.1H);
Some((-0.1G), (-0.1x), (-0.1H));
Some([@foo] (-1), [@foo] (-1), [@foo] (-1));
Some([@foo] (-1z), [@foo] (-1z), [@foo] (-1z));
Some([@foo] (-0.1), [@foo] (-0.1), [@foo] (-0.1));
Some([@foo] (-0.1m), [@foo] (-0.1n), [@foo] (-0.1p));
foo(~x=-1, ~y=-2);
foo(~x=(-1), ~y=(-2));
foo(~x=-.1, ~y=-.2);
foo(~x=(-.1), ~y=(-.2));
foo(~x=-1g, ~y=-1G, ~z=-1z);
foo(~x=(-1g), ~y=(-1G), ~z=(-1z));
foo(~x=-0.1G, ~y=-0.1x, ~z=-0.1H);
foo(~x=(-0.1G), ~y=(-0.1x), ~z=(-0.1H));
foo(~x=[@foo] (-1), ~y=[@foo] (-1), ~z=[@foo] (-1));
foo(~x=[@foo] (-1z), ~y=[@foo] (-1z), ~z=[@foo] (-1z));
foo(~x=[@foo] (-0.1), ~y=[@foo] (-0.1), ~z=[@foo] (-0.1));
foo(~x=[@foo] (-0.1m), ~y=[@foo] (-0.1n), ~z=[@foo] (-0.1p));
/* Smooth formatting of functions with callbacks as arguments */
funWithCb("text", () => doStuff());
funWithCb([@attr] "text", [@myAttr] () => doStuff());
funWithCb(~text="text", ~f=() => doStuff());
funWithCb(~text=[@attr] "text", ~f=[@myAttr] () => doStuff());
funWithCb(~text="text", ~f=?() => doStuff());
funWithCb(~text=[@attr] "text", ~f=?[@myAttr] () => doStuff());
test("my test", () => {
let x = a + b;
let y = z + c;
x + y
});
test([@attr] "my test", [@attr] () => {
let x = a + b;
let y = z + c;
x + y
});
test(~desc="my test", ~f=() => {
let x = a + b;
let y = z + c;
x + y
});
test(~desc=[@attr] "my test", ~f=[@myAttr] () => {
let x = a + b;
let y = z + c;
x + y
});
test(~desc=?"my test", ~f=?() => {
let x = a + b;
let y = z + c;
x + y
});
test(~desc=?[@attr] "my test", ~f=?[@attr] () => {
let x = a + b;
let y = z + c;
x + y
});
describe("App", () => {
test("math", () => {
Expect.expect(1+2) |> toBe(3)
});
});
describe([@attr] "App", [@attr] () => {
test([@attr] "math", [@attr] () => {
Expect.expect(1+2) |> toBe(3)
});
});
describe(~text="App", ~f=() =>
test(~text="math", ~f=() =>
Expect.expect(1 + 2) |> toBe(3)
)
);
describe(~text=[@attr] "App", ~f=[@attr] () =>
test(~text=[@attr] "math", ~f=[@attr] () =>
Expect.expect(1 + 2) |> toBe(3)
)
);
describe(~text=?"App", ~f=?() =>
test(~text=?"math", ~f=?() =>
Expect.expect(1 + 2) |> toBe(3)
)
);
describe(~text=?[@attr] "App", ~f=?[@attr] () =>
test(~text=?[@attr] "math", ~f=?[@attr] () =>
Expect.expect(1 + 2) |> toBe(3)
)
);
Thing.map(foo, bar, baz, (abc, z) =>
MyModuleBlah.toList(argument)
);
Thing.map([@attr] foo, bar, baz, [@attr] (abc, z) =>
MyModuleBlah.toList(argument)
);
Thing.map(~a=[@attr] foo, ~b=bar, ~c=?baz, ~f=(abc, z) =>
MyModuleBlah.toList(argument)
);
Thing.map(~a=foo, ~b=bar, ~c=?[@attr] baz, ~f=[@attr] (abc, z) =>
MyModuleBlah.toList(argument)
);
Thing.map(~a=foo, ~b=bar, ~c=?baz, ~f=?(abc, z) =>
MyModuleBlah.toList(argument)
);
Thing.map(~a=foo, ~b=bar, ~c=?[@attr] baz, ~f=?[@attr] (abc, z) =>
MyModuleBlah.toList(argument)
);
Thing.map(
foo,
bar,
baz,
foo2,
bakjlksjdf,
okokokok,
(abc, z) => {
let x = 1;
MyModuleBlah.toList(x, argument);
}
);
Thing.map(
foo,
bar,
baz,
foo2,
[@attr] bakjlksjdf,
okokokok,
[@attr] (abc, z) => {
let x = 1;
MyModuleBlah.toList(x, argument);
}
);
Thing.map(
~a=foo,
~b=bar,
~c=baz,
~d=foo2,
~e=bakjlksjdf,
~f=okokokok,
~cb=(abc, z) => {
let x = 1;
MyModuleBlah.toList(x, argument);
}
);
Thing.map(
~a=foo,
~b=bar,
~c=[@attr] baz,
~d=foo2,
~e=bakjlksjdf,
~f=okokokok,
~cb=[@attr] (abc, z) => {
let x = 1;
MyModuleBlah.toList(x, argument);
}
);
Thing.map(
~a=?foo,
~b=?bar,
~c=?baz,
~d=?foo2,
~e=?bakjlksjdf,
~f=?okokokok,
~cb=?(abc, z) => {
let x = 1;
MyModuleBlah.toList(x, argument);
}
);
Thing.map(
~a=?foo,
~b=?bar,
~c=?baz,
~d=?foo2,
~e=?[@attr] bakjlksjdf,
~f=?okokokok,
~cb=?[@attr] (abc, z) => {
let x = 1;
MyModuleBlah.toList(x, argument);
}
);
Thing.map(
foo,
bar,
baz,
(abc, z) => MyModuleBlah.toList(argument),
(abc, z) => MyModuleBlah.toList(argument)
);
Thing.map(
foo,
bar,
baz,
[@attr] (abc, z) => MyModuleBlah.toList(argument),
[@attr] (abc, z) => MyModuleBlah.toList(argument)
);
Js.Option.andThen([@bs] w => w#getThing());
Thing.map(
~a=?foo,
~b=?bar,
~c=?baz,
~d=?foo2,
~e=?[@attr] bakjlksjdf,
~f=?okokokok,
~cb=?[@attr] [@attr2] [@aslkdfjlsdjf][@sldkfjlksdjflksjdlkjf] [@sldkflskjdf] (abc, z) => {
let x = 1;
MyModuleBlah.toList(x, argument);
}
);
let result =
F.call(x => {
let x = 123;
let y = 2345;
doStuff();
});
let result = F.call(x => doStuff(x));
let () = x |> Bigarray.Genarray.get(_, [|1, 2, 3, 4|]);
let () = x |> Bigarray.Array1.get(_, 1);
let () = x |> Bigarray.Array2.get(_, 1, 2);
let () = x |> Bigarray.Array3.get(_, 1, 2, 3);
let x=-.1;
let x=-1;
let x=+1;
let x=+.1;
let x = (~a: int=- 1) => a;
let x = (~a=-1) => a;
let x: float=-.1;
let x: int =-1;
let x: int=+1;
let x: float =+. 1;
foo(~a=?-1);
/*
https://github.com/facebook/reason/issues/1992
Pexp_override
*/
let z = {<state: 0, x: y>};
let z = {<>};
/* https://github.com/facebook/reason/issues/2056 */
type foo = ~a:bool=? => int;
/* https://github.com/facebook/reason/issues/2070 */
f(~commit=!build);
/* https://github.com/facebook/reason/issues/2032 */
let predicate =
predicate === Functions.alwaysTrue1 ?
defaultPredicate :
(fun
| None => false
| Some(exn) => predicate(exn));
let predicate =
predicate === Functions.alwaysTrue1 ?
(fun
| None => false
| Some(exn) => predicate(exn)) :
(fun
| None => false
| Some(exn) => predicate(exn));
/* https://github.com/facebook/reason/issues/2125 */
foo(~a);
foo(~a: int);
foo(~(a: int));
foo(~(a :> int));
foo(~a :> int);
foo(~Foo.a?);
foo(~Foo.a);
/* https://github.com/facebook/reason/issues/2155#issuecomment-422077648 */
true ? (Update({...a, b: 1}), None) : x;
true ? ({...a, b: 1}) : a;
true ? (a, {...a, b: 1}) : a;
true ? ([x, ...xs]) => f(x, xs) : a;
/* https://github.com/facebook/reason/issues/2200 */
foo(~x=-1 + 2);
foo(~x=-1 + 2: int);
foo(~not);
let foo = (~not) => ();
let foo = (~not: string) => ();
foo(~not: string);
/* https://github.com/facebook/reason/issues/2141 */
let testCallNamedArgs = (foo: ((~a: int, ~b: int) => int), a, b) =>
foo(~a, ~b);
let testCallNamedArgs = (foo: ((~a: int, ~b: int=?) => int), a, b) =>
foo(~a, ~b);
let Foo.{name} = bar;
let Foo.Bar.{name} = bar;
let Foo.{
destruct1,
destruct2,
destruct3,
destruct4,
destruct5,
} = fooBar;
let Foo.[ name ] = bar;
let Foo.Bar.[ name ] = bar;
let Foo.Bar.[] = bar;
let Foo.Bar.[||] = bar;
let Foo.() = foo;
/* let Foo.(bar, baz) = foo; */
let Foo.(exception bar) = baz;
try({
let this = try_exp;
let has = hugged;
parens;
}) {
| _ => ()
};
/* Pcl_open (4.06+) */
class x = {
open EM;
as self;
};
class y = {
open EM;
open OM;
as self;
};
// Arbitrary precision literals
let x = 1G;
let x = 1.123g;
let x = switch () { | _ => .};
let%foo Foo.{
destruct1,
destruct2,
destruct3,
destruct4,
destruct5,
} = fooBar;
open%foo Bar;
open! %foo Bar;
let () = {
let open%foo Bar;
switch (1 + 1) {
| 2 => ()
| _ => ()
};
};
let () = {
let open%foo Bar;
3
};
let () = {
let open%foo Bar;
let x = 1;
3
};
module type x = {
let a: 'a. 'a => unit;
};
================================================
FILE: test/general-syntax-re.t/run.t
================================================
Format general implementation syntax
$ refmt ./input.re
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
[@autoFormat
let wrap = 80;
let shift = 2
];
Modules.run();
Polymorphism.run();
Variants.run();
BasicStructures.run();
TestUtils.printSection("General Syntax");
/* Won't work! */
/* let matchingFunc a = match a with */
/* `Thingy x => (print_string "matched thingy x"); x */
/* | `Other x => (print_string "matched other x"); x;; */
/* */
let matchingFunc = a =>
switch (a) {
| `Thingy(x) =>
print_string("matched thingy x");
let zz = 10;
zz;
| `Other(x) =>
print_string("matched other x");
x;
};
type firstTwoShouldBeGroupedInParens =
(int => int, int) => int;
type allParensCanBeRemoved =
(int, int, int) => int;
type firstTwoShouldBeGroupedAndFirstThree =
((int => int) => int) => int;
/* Same thing now but with type constructors instead of each int */
type firstTwoShouldBeGroupedInParens =
(list(int) => list(int), list(int)) =>
list(int);
type allParensCanBeRemoved =
(list(int), list(int), list(int)) =>
list(int);
type firstTwoShouldBeGroupedAndFirstThree =
((list(int) => list(int)) => list(int)) =>
list(int);
type myRecordType = {
firstTwoShouldBeGroupedInParens:
(int => int, int) => int,
allParensCanBeRemoved: (int, int, int) => int,
firstTwoShouldBeGroupedAndFirstThree:
((int => int) => int) => int,
};
type firstNamedArgShouldBeGroupedInParens =
(~first: int => int, ~second: int) => int;
type allParensCanBeRemoved =
(~first: int, ~second: int, ~third: int) => int;
type firstTwoShouldBeGroupedAndFirstThree =
(~first: (int => int) => int) => int;
/* Same thing now, but with type constructors instead of int */
type firstNamedArgShouldBeGroupedInParens =
(
~first: list(int) => list(int),
~second: list(int)
) =>
list(int);
type allParensCanBeRemoved =
(
~first: list(int),
~second: list(int),
~third: list(int)
) =>
list(int);
type firstTwoShouldBeGroupedAndFirstThree =
(
~first:
(list(int) => list(int)) => list(int)
) =>
list(int);
type firstNamedArgShouldBeGroupedInParens =
(
~first: int => int=?,
~second: list(int)=?
) =>
int;
/* The arrow necessitates parens around the next two args. The ? isn't what
* makes the parens necessary. */
type firstNamedArgShouldBeGroupedInParensAndSecondNamedArg =
(
~first: int => int=?,
~second: int => int=?
) =>
int;
type allParensCanBeRemoved =
(
~first: int=?,
~second: int=?,
~third: int=?
) =>
int;
type firstTwoShouldBeGroupedAndFirstThree =
(~first: (int => int) => int) => int;
type noParens =
(~one: int, int, int, ~two: int) => int;
type noParensNeeded =
(~one: int, int, int, ~two: int) => int;
type firstNamedArgNeedsParens =
(~one: (int, int) => int, ~two: int) => int;
/* Now, let's try type aliasing */
/* Unless wrapped in parens, types between arrows may not be aliased, may not
* themselves be arrows. */
type parensRequiredAroundFirstArg =
(list(int) as 'a) => int as 'a;
type parensRequiredAroundReturnType =
(list(int) as 'a) => (int as 'a);
type parensRequiredAroundReturnType =
(list(int) as 'a) => (int as 'a) as 'b;
type noParensNeededWhenInTuple =
(list(int) as 'a, list(int) as 'b) as 'entireThing;
type myTypeDef('a) = list('a);
type instatiatedTypeDef = myTypeDef(int) => int;
/* Test a type attribute for good measure */
/* We should clean up all of the attribute tagging eventually, but for now,
* let's make it super ugly to get out of the way of all the formatting/parsing
* implementations (fewer conflicts during parsing, fewer edge cases during
* printing).
*/
type something = (
int,
[@lookAtThisAttribute] int,
);
type longWrappingTypeDefinitionExample =
M_RK__G.Types.instance(
TGRecognizer.tGFields(unit, unit),
TGRecognizer.tGMethods(unit, unit),
);
type semiLongWrappingTypeDefinitionExample =
M_RK__Gesture.Types.instance(
TGRecognizerFinal.tGFields,
TGRecognizerFinal.tGMethods,
);
type semiLongWrappingTypeWithConstraint =
M_RK__Gesture.Types.instance(
'a,
TGRecognizerFinal.tGFields,
TGRecognizerFinal.tGMethods,
)
constraint 'a = (unit, unit);
type onelineConstrain = 'a constraint 'a = int;
/* This must be in trunk but not in this branch of OCaml */
/* type withNestedRecords = MyConstructor {myField: int} */
type colors =
| Red(int)
| Black(int)
| Green(int);
/* Another approach is to require declared variants to wrap any record */
/* type myRecord = MyRecord {name: int}; */
/* let myValue = MyRecord {name: int}; */
/* This would force importing of the module */
/* This would also lend itself naturally to pattern matching - and avoid having
to use `.` operator at all since you normally destructure. */
type nameBlahType = {nameBlah: int};
let myRecord = { nameBlah: 20 };
let myRecordName = myRecord.nameBlah;
let { nameBlah }: nameBlahType = {
nameBlah: 20,
};
print_int(nameBlah);
let { nameBlah: aliasedToThisVar }: nameBlahType = {
nameBlah: 20,
};
print_int(aliasedToThisVar);
let desiredFormattingForWrappedLambda
: (int, int, int) => nameBlahType =
/*
fun is
pre- /firstarg\
fix /-coupled--\
|-\ /-to-prefix--\ */
(curriedArg, anotherArg, lastArg) => {
nameBlah: 10,
};
type longerInt = int;
let desiredFormattingForWrappedLambdaWrappedArrow
: (longerInt, longerInt, longerInt) =>
nameBlahType =
/*
fun is
pre- /firstarg\
fix /-coupled--\
|-\ /-to-prefix--\ */
(curriedArg, anotherArg, lastArg) => {
nameBlah: 10,
};
let desiredFormattingForWrappedLambdaReturnOnNewLine =
/*
fun is
pre- /firstarg\
fix /-coupled--\
|-\ /-to-prefix--\ */
(curriedArg, anotherArg, lastArg) => {
nameBlah: 10,
};
/*
let is
pre-
fix /-function binding name---\
|-\ / is coupled to prefix \ */
let desiredFormattingForWrappedSugar =
(curriedArg, anotherArg, lastArg) => {
nameBlah: 10,
};
/*
let is
pre-
fix /-function binding name---\
|-\ / is coupled to prefix \ */
let desiredFormattingForWrappedSugarReturnOnNewLine =
(curriedArg, anotherArg, lastArg) => {
nameBlah: 10,
};
/*
let : type t1 t2. t1 * t2 list -> t1 = ...
let rec f : 't1 't2. 't1 * 't2 list -> 't1 =
fun (type t1) (type t2) -> (... : t1 * t2 list -> t1)
*/
type point = {
x: int,
y: int,
};
type point3D = {
x: int,
y: int,
z: int,
};
let point2D = {
x: 20,
y: 30,
};
let point3D: point3D = {
x: 10,
y: 11,
z: 80 /* Optional Comma */
};
let printPoint = (p: point) => {
print_int(p.x);
print_int(p.y);
};
let addPoints = (p1: point, p2: point) => {
x: p1.x + p2.x,
y: p1.y + p2.y,
};
let res1 = printPoint(point2D);
let res2 =
printPoint({
x: point3D.x,
y: point3D.y,
});
/*
When () were used to indicate sequences, the parser used seq_expr not only
for grouping sequences, but also to form standard precedences.
/------- sequence_expr ------\
let res3 = printPoint (addPoints (point2D, point3D));
Interestingly, it knew that tuples aren't sequences.
To move towards semi delimited, semi-terminated, braces-grouped sequences:
while allowing any non-sequence expression to be grouped on parens, we make
an explicit rule that allows one single non-semi ended expression to be
grouped in parens.
Actually: We will allow an arbitrary number of semi-delimited expressions to
be wrapped in parens, but the braces grouped semi delimited (sequence)
expressions must *also* be terminated with a semicolon.
This allows the parser to distinguish between
let x = {a}; /* Record {a:a} */
let x = {a;}; /* Single item sequence returning identifier {a} */
*/
let res3 =
printPoint(
addPoints(
point2D,
{
x: point3D.x,
y: point3D.y,
},
),
);
type person = {
age: int,
name: string,
};
type hiredPerson = {
age: string,
name: string,
dateHired: int,
};
let o: person = {
name: "bob",
age: 10,
};
/* Parens needed? Nope! */
let o: person = {
name: "bob",
age: 10,
};
let printPerson = (p: person) => {
let q: person = p;
p.name ++ p.name;
};
/* let dontParseMeBro x y:int = x = y;*/
/* With this unification, anywhere eyou see `= fun` you can just ommit it */
let blah = a => a; /* Done */
let blah = a => a; /* Done (almost) */
let blah = (a, b) => a; /* Done */
let blah = (a, b) => a; /* Done (almost) */
/* More than one consecutive pattern must have a single case */
type blah = {blahBlah: int};
let blah = (a, { blahBlah }) => a;
let blah = (a, { blahBlah }) => a;
module TryToExportTwice = {
let myVal = "hello";
};
/*
Unifying top level module syntax with local module syntax is probably a bad
idea at the moment because it makes it more difficult to continue to support
`let .. in` bindings. We can distinguish local modules for `let..in` that
just happen to be defined at the top level (but not exported).
let MyModule = {let myVal = 20;} in
MyModule.x
Wait, where would this ever be valid, even if we continued to support
`let..in`?
*/
let onlyDoingThisTopLevelLetToBypassTopLevelSequence = {
let x = {
print_int(1);
print_int(20); /* Missing trailing SEMI */
};
let x = {
print_int(1);
print_int(20); /* Ensure missing middle SEMI reported well */
print_int(20);
};
let x = {
print_int(1);
print_int(20);
10;
/* Comment in final position */
}; /* Missing final SEMI */
x + x;
};
type hasA = {a: int};
let a = 10;
let returnsASequenceExpressionWithASingleIdentifier =
() => {
a;
};
let thisReturnsA = () => {
a;
};
let thisReturnsAAsWell = () => a;
let recordVal: int = thisReturnsARecord().a;
Printf.printf(
"\nproof that thisReturnsARecord: %n\n",
recordVal,
);
Printf.printf(
"\nproof that thisReturnsA: %n\n",
thisReturnsA(),
);
/* Pattern matching */
let blah = arg =>
switch (arg) {
/* Comment before Bar */
| /* Comment between bar/pattern */ Red(_) => 1
/* Comment Before non-first bar */
| /* Comment betwen bar/pattern */ Black(_) => 0
| Green(_) => 0
};
/* Any function that pattern matches a multicase match is interpretted as a
* single arg that is then matched on. Instead of the above `blah` example:*/
let blah =
fun
| Red(_) => 1
| Black(_) => 0
| Green(_) => 1;
/* `fun a => a` is read as "a function that maps a to a". Then the */
/* above example is read: "a function that 'either maps' Red to.. or maps .." */
/* Thc00f564e first bar is read as "either maps" */
/* Curried form is not supported:
let blah x | Red _ => 1 | Black _ => 0;
Theres no sugar rule for dropping => fun, only = fun
*/
/* let blahCurriedX x => fun /* See, nothing says we can drop the => fun */ */
/* |(Red x | Black x | Green x) => 1 /* With some effort, we can ammend the sugar rule that would */ */
/* | Black x => 0 /* Allow us to drop any => fun.. Just need to make pattern matching */ */
/* | Green x => 0; /* Support that */ */
/* */
let blahCurriedX = x =>
fun
| Red(x)
| Black(x)
| Green(x) => 1 /* With some effort, we can ammend the sugar rule that would */
| Black(x) => 0 /* Allow us to drop any => fun.. Just need to make pattern matching */
| Green(x) => 0; /* Support that */
let sameThingInLocal = {
let blahCurriedX = x =>
fun
| Red(x)
| Black(x)
| Green(x) => 1 /* With some effort, we can ammend the sugar rule that would */
| Black(x) => 0 /* Allow us to drop any => fun.. Just need to make pattern matching */
| Green(x) => 0; /* Support that */
blahCurriedX;
};
/* This should be parsed/printed exactly as the previous */
let blahCurriedX = x =>
fun
| Red(x)
| Black(x)
| Green(x) => 1
| Black(x) => 0
| Green(x) => 0;
/* Any time there are multiple match cases we require a leading BAR */
let v = Red(10);
let Black(x) | Red(x) | Green(x) = v; /* So this NON-function still parses */
/* This doesn't parse, however (and it doesn't in OCaml either):
let | Black(x) | Red(x) | Green(x) = v;
*/
print_int(x);
/* Scoping: Let sequences. Familiar syntax for lexical ML style scope and
sequences. */
let res = {
let a = "a starts out as";
{
print_string(a);
let a = 20;
print_int(a);
};
print_string(a);
};
let res = {
let a = "first its a string";
let a = 20;
print_int(a);
print_int(a);
print_int(a);
};
let res = {
let a = "a is always a string";
print_string(a);
let b = 30;
print_int(b);
};
/* let result = LyList.map((fun | [] => true | _ => false), []); */
/* OTHERWISE: You cannot tell if a is the first match case falling through or
* a curried first arg */
/* let blah = fun a | patt => 0 | anotherPatt => 1; */
/* let blah a patt => 0 | anotherPatt => 1; */
/*simple pattern EQUALGREATER expr */
let blah = (a, { blahBlah }) => a;
/* match_case */
/* pattern EQUALGREATER expr */
let blah =
fun
| Red(_) => 1
| Black(_) => 0
| Green(_) => 0;
/* Won't work! */
/* let arrowFunc = fun a b => print_string "returning aplusb from arrow"; a + b;; */
let arrowFunc = (a, b) => {
print_string("returning aplusb from arrow");
a + b;
};
let add = (a, b) => {
let extra = {
print_string("adding");
0;
};
let anotherExtra = 0;
extra + a + b + anotherExtra;
};
print_string(string_of_int(add(4, 34)));
let dummy = _ => 10;
dummy(res1);
dummy(res2);
dummy(res3);
/* Some edge cases */
let myFun =
(firstArg, Red(x) | Black(x) | Green(x)) =>
firstArg + x;
let matchesWithWhen = a =>
switch (a) {
| Red(x) when 1 > 0 => 10
| Red(_) => 10
| Black(x) => 10
| Green(x) => 10
};
let matchesWithWhen =
fun
| Red(x) when 1 > 0 => 10
| Red(_) => 10
| Black(x) => 10
| Green(x) => 10;
let matchesOne = (`Red(x)) => 10;
/*
Typical OCaml would make you *wrap the functions in parens*! This is because it
can't tell if a semicolon is a sequence operator. Even if we had records use
commas to separate fields,
*/
type adders = {
addTwoNumbers: (int, int) => int,
addThreeNumbers: (int, int, int) => int,
addThreeNumbersTupled:
((int, int, int)) => int,
};
let myRecordWithFunctions = {
addTwoNumbers: (a, b) => a + b,
addThreeNumbers: (a, b, c) => a + b + c,
addThreeNumbersTupled: ((a, b, c)) =>
a + b + c,
};
let result =
myRecordWithFunctions.addThreeNumbers(
10,
20,
30,
);
let result =
myRecordWithFunctions.addThreeNumbersTupled((
10,
20,
30,
));
let lookTuplesRequireParens = (1, 2);
/* let thisDoesntParse = 1, 2; */
let tupleInsideAParenSequence = {
print_string(
"look, a tuple inside a sequence",
);
let x = 10;
(x, x);
};
let tupleInsideALetSequence = {
print_string(
"look, a tuple inside a sequence",
);
let x = 10;
(x, x);
};
/* We *require* that function return types be wrapped in
parenthesis. In this example, there's no ambiguity */
let makeIncrementer = (delta: int): (int => int) =>
a => a + delta;
/* We could even force that consistency with let bindings - it's allowed
currently but not forced.
*/
let (myAnnotatedValBinding: int) = 10;
/* Class functions (constructors) and methods are unified in the same way */
class classWithNoArg = {
pub x = 0;
pub y = 0;
};
/* This parses but doesn't type check
class myClass init => object
pub x => init
pub y => init
end;
*/
let myFunc = (a: int, b: int): (int, int) => (
a,
b,
);
let myFunc = (a: int, b: int): list(int) => [
1,
];
let myFunc = (a: int, b: int): point => {
x: a,
y: b,
};
let myFunc = (a: int, b: int): point => {
x: a,
y: b,
};
type myThing = (int, int);
type stillARecord = {
name: string,
age: int,
};
/* Rebase latest OCaml to get the following: And fixup
`generalized_constructor_arguments` according to master. */
/* type ('a, 'b) myOtherThing = Leaf {first:'a, second: 'b} | Null; */
type branch('a, 'b) = {
first: 'a,
second: 'b,
};
type myOtherThing('a, 'b) =
| Leaf(branch('a, 'b))
| Null;
type yourThing = myOtherThing(int, int);
/* Conveniently - this parses exactly how you would intend! No *need* to wrap
in an extra [], but it doesn't hurt */
/* FIXME type lookAtThesePolyVariants = list [`Red] ; */
/* FIXME type bracketsGroupMultipleParamsAndPrecedence = list (list (list [`Red])); */
/* FIXME type youCanWrapExtraIfYouWant = (list [`Red]); */
/* FIXME type hereAreMultiplePolyVariants = list [`Red | `Black]; */
/* FIXME type hereAreMultiplePolyVariantsWithOptionalWrapping = list ([`Red | `Black]); */
/*
/* Proposal: ES6 style lambdas: */
/* Currying */
let lookES6Style = (`Red x) (`Black y) => { };
let lookES6Style (`Red x) (`Black y) => { };
/* Matching the single argument */
let lookES6Style = oneArg => match oneArg with
| `Red x => x
| `Black x => x;
/* The "trick" to currying that we already have is basically the same - we just
* have to reword it a bit:
* From:
* "Any time you see [let x = fun ...] just replace it with [let x ...]"
* To:
* "Any time you see [let x = ... => ] just replace it with [let x ... => ]"
*/
let lookES6Style oneArg => match oneArg with
| `Red x => x
| `Black x => x;
*/
/** Current OCaml Named Arguments. Any aliasing is more than just aliasing!
OCaml allows full on pattern matching of named args. */
/*
A: let named ~a ~b = aa + bb in
B: let namedAlias ~a:aa ~b:bb = aa + bb in
C: let namedAnnot ~(a:int) ~(b:int) = a + b in
D: let namedAliasAnnot ~a:(aa:int) ~b:(bb:int) = aa + bb in
E: let optional ?a ?b = 10 in
F: let optionalAlias ?a:aa ?b:bb = 10 in
G: let optionalAnnot ?(a:int option) ?(b:int option) = 10 in
H: let optionalAliasAnnot ?a:(aa:int option) ?b:(bb:int option) = 10 in
/*
Look! When a default is provided, annotation causes inferred type of argument
to not be "option" since it's automatically destructured (because we know it
will always be available one way or another.)
*/
I: let defOptional ?(a=10) ?(b=10) = 10 in
J: let defOptionalAlias ?a:(aa=10) ?b:(bb=10) = 10 in
K: let defOptionalAnnot ?(a:int=10) ?(b:int=10) = 10 in
\ \
\label_let_pattern opt_default: no longer needed in SugarML
L: let defOptionalAliasAnnot ?a:(aa:int=10) ?b:(bb:int=10) = 10 in
\ \
\let_pattern: still a useful syntactic building block in SugarML
*/
/**
* In Reason, the syntax for named args uses double semicolon, since
* the syntax for lists uses ES6 style [], freeing up the ::.
*/
let a = 10;
let b = 20;
/*A*/
let named = (~a, ~b) => a + b;
type named = (~a: int, ~b: int) => int;
/*B*/
let namedAlias = (~a as aa, ~b as bb) =>
aa + bb;
let namedAlias = (~a as aa, ~b as bb) =>
aa + bb;
type namedAlias = (~a: int, ~b: int) => int;
/*C*/
let namedAnnot = (~a: int, ~b: int) => 20;
/*D*/
let namedAliasAnnot =
(~a as aa: int, ~b as bb: int) => 20;
/*E*/
let myOptional = (~a=?, ~b=?, ()) => 10;
type named = (~a: int=?, ~b: int=?, unit) => int;
/*F*/
let optionalAlias = (~a as aa=?, ~b as bb=?, ()) => 10;
/*G*/
let optionalAnnot = (~a: int=?, ~b: int=?, ()) => 10;
/*H*/
let optionalAliasAnnot =
(~a as aa: int=?, ~b as bb: int=?, ()) => 10;
/*I: */
let defOptional = (~a=10, ~b=10, ()) => 10;
type named = (~a: int=?, ~b: int=?, unit) => int;
/*J*/
let defOptionalAlias =
(~a as aa=10, ~b as bb=10, ()) => 10;
/*K*/
let defOptionalAnnot =
(~a: int=10, ~b: int=10, ()) => 10;
/*L*/
let defOptionalAliasAnnot =
(~a as aa: int=10, ~b as bb: int=10, ()) => 10;
/*M: Invoking them - Punned */
let resNotAnnotated = named(~a, ~b);
/*N:*/
let resAnnotated: int = named(~a, ~b);
/*O: Invoking them */
let resNotAnnotated = named(~a, ~b);
/*P: Invoking them */
let resAnnotated: int = named(~a, ~b);
/*Q: Here's why "punning" doesn't work! */
/* Is b:: punned with a final non-named arg, or is b:: supplied b as one named arg? */
let b = 20;
let resAnnotated = named(~a, ~b);
/*R: Proof that there are no ambiguities with return values being annotated */
let resAnnotated: ty = named(~a, b);
/*S: Explicitly passed optionals are a nice way to say "use the default value"*/
let explictlyPassed =
myOptional(~a=?None, ~b=?None);
/*T: Annotating the return value of the entire function call */
let explictlyPassedAnnotated: int =
myOptional(~a=?None, ~b=?None);
/*U: Explicitly passing optional with identifier expression */
let a = None;
let explictlyPassed = myOptional(~a?, ~b=?None);
let explictlyPassedAnnotated: int =
myOptional(~a?, ~b=?None);
let nestedLet = {
let _ = 1;
();
};
let nestedLet = {
let _ = 1;
();
};
let nestedLet = {
let _ = 1;
();
};
let nestedLet = {
let _ = 1;
2;
};
/*
* Showing many combinations of type annotations and named arguments.
*/
type typeWithNestedNamedArgs =
(
~outerOne:
(~innerOne: int, ~innerTwo: int) => int,
~outerTwo: int
) =>
int;
type typeWithNestedOptionalNamedArgs =
(
~outerOne:
(~innerOne: int, ~innerTwo: int) => int=?,
~outerTwo: int=?
) =>
int;
type typeWithNestedOptionalNamedArgs =
(
~outerOne: list(string)=?,
~outerTwo: int=?
) =>
int;
let f =
(~tuple="long string to trigger line break") =>
();
let x =
callSomeFunction(
~withArg=10,
~andOtherArg=wrappedArg,
);
let res = {
(constraintedSequenceItem: string);
(dontKnowWheYoudWantToActuallyDoThis: string);
};
let res = {
(
butTheyWillBePrintedWithAppropriateSpacing: string
);
(
soAsToInstillBestDevelopmentPractices: string
);
};
let x = [
(eachItemInListCanBeAnnotated: int),
(typeConstraints: float),
(
tupleConstraints: int,
andNotFunctionInvocations: int,
),
];
let x = [
(butWeWillPrint: int),
(themAsSpaceSeparated: float),
(
toInfluenceYour: int,
developmentHabbits: int,
),
];
let newRecord = {
...(annotatedSpreadRecord: someRec),
x: y,
};
let newRecord = {
...(annotatedSpreadRecord: someRec),
blah: 0,
foo: 1,
};
let newRecord = {
...(
youCanEvenCallMethodsHereAndAnnotate(them): someRec
),
blah: 0,
foo: 1,
};
let newRecord = {
...(
youCanEvenCallMethodsHereAndAnnotate(
them,
~named=10,
): someRec
),
blah: 0,
foo: 1,
};
let something: thing(blah) = aTypeAnnotation;
let something: thing(blah) = thisIsANamedArg;
let something: thing(blah) = aTypeAnnotation;
let something: blah = thisIsANamedArg(thing);
let something: blah = typeAnnotation(thing);
let newRecord = {
...(
heresAFunctionWithNamedArgs(~argOne=i): annotatedResult
),
soAsToInstill: 0,
developmentHabbits: 1,
};
[@thisIsAThing];
let x = 10;
/* Ensure that the parenthesis are preserved here because they are
* important:
*/
let something =
fun
| None => (
fun
| [] => "emptyList"
| [_, ..._] => "nonEmptyList"
)
| Some(_) => (
fun
| [] => "emptyList"
| [_, ..._] => "nonEmptyList"
);
/* A | B = X; */
let A | B = X;
/* A | (B | C) = X; */
let A | (B | C) = X;
/* (A | B) | (C | D) = X; */
let A | B | (C | D) = X;
/* A | B | (C | D) = X; */
let A | B | (C | D) = X;
/* (A | B) | C = X; */
let A | B | C = X;
/* A | B | C = X; */
let A | B | C = X;
/** External function declaration
*
*/
external f: int => int = "foo";
let x = { contents: 0 };
let unitVal = x.contents = 210;
let match = "match";
let method = "method";
let foo =
(x, ~x as bar, ~z, ~foo as bar, ~foo as z) => {
bar + 2;
};
let zzz = myFunc(1, 2, [||]);
/* 1492 */
let registerEventHandlers =
(
~window: Window.t,
~mouseDown:
option(
(
~button: Events.buttonStateT,
~state: Events.stateT,
~x: int,
~y: int
) =>
unit,
)=?,
(),
) => 1;
/* #1320: record destrucuring + renaming */
let x = ({ state as prevState }) => 1;
let x = ({ ReasonReact.state as prevState }) => 1;
/* 1567: optional parens around expr constraint in constructor expression */
Some(x: int);
Some(x: int);
Some(x, y: int, b);
Some(x, y: int, b);
foo(~x=-. bar);
Some(-1, -1, -1);
Some(-1, -1, -1);
Some(-1g, -1G, -1z);
Some(-1g, -1G, -1z);
Some(-0.1, -0.1, -0.1);
Some(-0.1, -0.1, -0.1);
Some(-0.1G, -0.1x, -0.1H);
Some(-0.1G, -0.1x, -0.1H);
Some([@foo] -1, [@foo] -1, [@foo] -1);
Some([@foo] -1z, [@foo] -1z, [@foo] -1z);
Some([@foo] -0.1, [@foo] -0.1, [@foo] -0.1);
Some([@foo] -0.1m, [@foo] -0.1n, [@foo] -0.1p);
foo(~x=-1, ~y=-2);
foo(~x=-1, ~y=-2);
foo(~x=-. 1, ~y=-. 2);
foo(~x=-. 1, ~y=-. 2);
foo(~x=-1g, ~y=-1G, ~z=-1z);
foo(~x=-1g, ~y=-1G, ~z=-1z);
foo(~x=-0.1G, ~y=-0.1x, ~z=-0.1H);
foo(~x=-0.1G, ~y=-0.1x, ~z=-0.1H);
foo(~x=[@foo] -1, ~y=[@foo] -1, ~z=[@foo] -1);
foo(
~x=[@foo] -1z,
~y=[@foo] -1z,
~z=[@foo] -1z,
);
foo(
~x=[@foo] -0.1,
~y=[@foo] -0.1,
~z=[@foo] -0.1,
);
foo(
~x=[@foo] -0.1m,
~y=[@foo] -0.1n,
~z=[@foo] -0.1p,
);
/* Smooth formatting of functions with callbacks as arguments */
funWithCb("text", () => doStuff());
funWithCb([@attr] "text", [@myAttr] () =>
doStuff()
);
funWithCb(~text="text", ~f=() => doStuff());
funWithCb(~text=[@attr] "text", ~f=[@myAttr] () =>
doStuff()
);
funWithCb(~text="text", ~f=?() => doStuff());
funWithCb(~text=[@attr] "text", ~f=?[@myAttr] () =>
doStuff()
);
test("my test", () => {
let x = a + b;
let y = z + c;
x + y;
});
test([@attr] "my test", [@attr] () => {
let x = a + b;
let y = z + c;
x + y;
});
test(~desc="my test", ~f=() => {
let x = a + b;
let y = z + c;
x + y;
});
test(~desc=[@attr] "my test", ~f=[@myAttr] () => {
let x = a + b;
let y = z + c;
x + y;
});
test(~desc=?"my test", ~f=?() => {
let x = a + b;
let y = z + c;
x + y;
});
test(~desc=?[@attr] "my test", ~f=?[@attr] () => {
let x = a + b;
let y = z + c;
x + y;
});
describe("App", () => {
test("math", () => {
Expect.expect(1 + 2) |> toBe(3)
})
});
describe([@attr] "App", [@attr] () => {
test([@attr] "math", [@attr] () => {
Expect.expect(1 + 2) |> toBe(3)
})
});
describe(~text="App", ~f=() =>
test(~text="math", ~f=() =>
Expect.expect(1 + 2) |> toBe(3)
)
);
describe(~text=[@attr] "App", ~f=[@attr] () =>
test(~text=[@attr] "math", ~f=[@attr] () =>
Expect.expect(1 + 2) |> toBe(3)
)
);
describe(~text=?"App", ~f=?() =>
test(~text=?"math", ~f=?() =>
Expect.expect(1 + 2) |> toBe(3)
)
);
describe(~text=?[@attr] "App", ~f=?[@attr] () =>
test(~text=?[@attr] "math", ~f=?[@attr] () =>
Expect.expect(1 + 2) |> toBe(3)
)
);
Thing.map(foo, bar, baz, (abc, z) =>
MyModuleBlah.toList(argument)
);
Thing.map(
[@attr] foo, bar, baz, [@attr] (abc, z) =>
MyModuleBlah.toList(argument)
);
Thing.map(
~a=[@attr] foo, ~b=bar, ~c=?baz, ~f=(abc, z) =>
MyModuleBlah.toList(argument)
);
Thing.map(
~a=foo,
~b=bar,
~c=?[@attr] baz,
~f=[@attr] (abc, z) =>
MyModuleBlah.toList(argument)
);
Thing.map(~a=foo, ~b=bar, ~c=?baz, ~f=?(abc, z) =>
MyModuleBlah.toList(argument)
);
Thing.map(
~a=foo,
~b=bar,
~c=?[@attr] baz,
~f=?[@attr] (abc, z) =>
MyModuleBlah.toList(argument)
);
Thing.map(
foo,
bar,
baz,
foo2,
bakjlksjdf,
okokokok,
(abc, z) => {
let x = 1;
MyModuleBlah.toList(x, argument);
},
);
Thing.map(
foo,
bar,
baz,
foo2,
[@attr] bakjlksjdf,
okokokok,
[@attr] (abc, z) => {
let x = 1;
MyModuleBlah.toList(x, argument);
},
);
Thing.map(
~a=foo,
~b=bar,
~c=baz,
~d=foo2,
~e=bakjlksjdf,
~f=okokokok,
~cb=(abc, z) => {
let x = 1;
MyModuleBlah.toList(x, argument);
},
);
Thing.map(
~a=foo,
~b=bar,
~c=[@attr] baz,
~d=foo2,
~e=bakjlksjdf,
~f=okokokok,
~cb=[@attr] (abc, z) => {
let x = 1;
MyModuleBlah.toList(x, argument);
},
);
Thing.map(
~a=?foo,
~b=?bar,
~c=?baz,
~d=?foo2,
~e=?bakjlksjdf,
~f=?okokokok,
~cb=?(abc, z) => {
let x = 1;
MyModuleBlah.toList(x, argument);
},
);
Thing.map(
~a=?foo,
~b=?bar,
~c=?baz,
~d=?foo2,
~e=?[@attr] bakjlksjdf,
~f=?okokokok,
~cb=?[@attr] (abc, z) => {
let x = 1;
MyModuleBlah.toList(x, argument);
},
);
Thing.map(
foo,
bar,
baz,
(abc, z) => MyModuleBlah.toList(argument),
(abc, z) => MyModuleBlah.toList(argument),
);
Thing.map(
foo,
bar,
baz,
[@attr] (abc, z) =>
MyModuleBlah.toList(argument),
[@attr] (abc, z) =>
MyModuleBlah.toList(argument),
);
Js.Option.andThen((. w) => w#getThing());
Thing.map(
~a=?foo,
~b=?bar,
~c=?baz,
~d=?foo2,
~e=?[@attr] bakjlksjdf,
~f=?okokokok,
~cb=?[@attr]
[@attr2]
[@aslkdfjlsdjf]
[@sldkfjlksdjflksjdlkjf]
[@sldkflskjdf]
(abc, z) => {
let x = 1;
MyModuleBlah.toList(x, argument);
},
);
let result =
F.call(x => {
let x = 123;
let y = 2345;
doStuff();
});
let result = F.call(x => doStuff(x));
let () =
x |> Bigarray.Genarray.get(_, [|1, 2, 3, 4|]);
let () = x |> Bigarray.Array1.get(_, 1);
let () = x |> Bigarray.Array2.get(_, 1, 2);
let () = x |> Bigarray.Array3.get(_, 1, 2, 3);
let x = -. 1;
let x = (-1);
let x = 1;
let x = +. 1;
let x = (~a: int=(-1)) => a;
let x = (~a=(-1)) => a;
let x: float = -. 1;
let x: int = (-1);
let x: int = 1;
let x: float = +. 1;
foo(~a=?-1);
/*
https://github.com/facebook/reason/issues/1992
Pexp_override
*/
let z = {<state: 0, x: y>};
let z = {<>};
/* https://github.com/facebook/reason/issues/2056 */
type foo = (~a: bool=?) => int;
/* https://github.com/facebook/reason/issues/2070 */
f(~commit=!build);
/* https://github.com/facebook/reason/issues/2032 */
let predicate =
predicate === Functions.alwaysTrue1
? defaultPredicate
: fun
| None => false
| Some(exn) => predicate(exn);
let predicate =
predicate === Functions.alwaysTrue1
? fun
| None => false
| Some(exn) => predicate(exn)
: fun
| None => false
| Some(exn) => predicate(exn);
/* https://github.com/facebook/reason/issues/2125 */
foo(~a);
foo(~a: int);
foo(~a: int);
foo(~(a :> int));
foo(~(a :> int));
foo(~a=?Foo.a);
foo(~a=Foo.a);
/* https://github.com/facebook/reason/issues/2155#issuecomment-422077648 */
true
? (
Update({
...a,
b: 1,
}),
None,
)
: x;
true
? {
...a,
b: 1,
}
: a;
true
? (
a,
{
...a,
b: 1,
},
)
: a;
true ? ([x, ...xs]) => f(x, xs) : a;
/* https://github.com/facebook/reason/issues/2200 */
foo(~x=(-1) + 2);
foo(~x=(-1) + 2: int);
foo(~not);
let foo = (~not) => ();
let foo = (~not: string) => ();
foo(~not: string);
/* https://github.com/facebook/reason/issues/2141 */
let testCallNamedArgs =
(foo: (~a: int, ~b: int) => int, a, b) =>
foo(~a, ~b);
let testCallNamedArgs =
(foo: (~a: int, ~b: int=?) => int, a, b) =>
foo(~a, ~b);
let Foo.{ name } = bar;
let Foo.Bar.{ name } = bar;
let Foo.{
destruct1,
destruct2,
destruct3,
destruct4,
destruct5,
} = fooBar;
let Foo.[name] = bar;
let Foo.Bar.[name] = bar;
let Foo.Bar.[] = bar;
let Foo.Bar.[||] = bar;
let Foo.() = foo;
/* let Foo.(bar, baz) = foo; */
let Foo.(exception bar) = baz;
try({
let this = try_exp;
let has = hugged;
parens;
}) {
| _ => ()
};
/* Pcl_open (4.06+) */
class x = {
open EM;
as self;
};
class y = {
open EM;
open OM;
as self;
};
// Arbitrary precision literals
let x = 1G;
let x = 1.123g;
let x =
switch () {
| _ => .
};
let%foo Foo.{
destruct1,
destruct2,
destruct3,
destruct4,
destruct5,
} = fooBar;
open%foo Bar;
open! %foo Bar;
let () = {
open%foo Bar;
switch (1 + 1) {
| 2 => ()
| _ => ()
};
};
let () = {
open%foo Bar;
3;
};
let () = {
open%foo Bar;
let x = 1;
3;
};
module type x = {
let a: 'a. 'a => unit;
};
================================================
FILE: test/general-syntax-rei.t/input.rei
================================================
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
/**
* Typically the "interface file" is where you would write a ton of
* comments/documentation.
*/
type adders = {
/*
* Adds two numbers together.
*/
addTwoNumbers: (int, int) => int,
/*
* Amazingly, adds *three* numbers together.
*/
addThreeNumbers: (int, int, int) => int,
/*
* Tuple version of previous function.
*/
addThreeNumbersTupled: ((int, int, int)) => int,
};
/**
* Public function.
*/
let myRecordWithFunctions: adders;
/**
* Public result.
*/
let result: int;
/* https://github.com/facebook/reason/issues/1614 */
module Event: (module type of { include ReactEventRe; });
module type Event = (module type of { include ReactEventRe; });
/* https://github.com/facebook/reason/issues/2169 */
let not : string => string;
let other : string => not;
include (module type of Bos.Cmd) with type t = Bos.Cmd.t;
external%foo bar: string => string = "";
[%%foo: external bar: int => int = "hello" ];
[%%foo: let foo: bar];
let%foo foo: bar;
module%foo X: Y;
module%foo X = Y;
module%foo rec X: Y;
let wrapReasonForJs:
(
~component: componentSpec(
'state,
'initialState,
'retainedProps,
'initialRetainedPropssssssssssssssssss,
'action
)
) =>
reactClass;
open%foo Bar;
open! %foo Bar;
type%foo t = int;
type%x foo += Int;
module type x = {
let a: 'a. 'a => unit;
};
let a: 'a. 'a => unit;
================================================
FILE: test/general-syntax-rei.t/run.t
================================================
Format general interface syntax
$ refmt ./input.rei
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
/**
* Typically the "interface file" is where you would write a ton of
* comments/documentation.
*/
type adders = {
/*
* Adds two numbers together.
*/
addTwoNumbers: (int, int) => int,
/*
* Amazingly, adds *three* numbers together.
*/
addThreeNumbers: (int, int, int) => int,
/*
* Tuple version of previous function.
*/
addThreeNumbersTupled:
((int, int, int)) => int,
};
/**
* Public function.
*/
let myRecordWithFunctions: adders;
/**
* Public result.
*/
let result: int;
/* https://github.com/facebook/reason/issues/1614 */
module Event: (module type of {
include ReactEventRe;
});
module type Event = (module type of {
include ReactEventRe;
});
/* https://github.com/facebook/reason/issues/2169 */
let not: string => string;
let other: string => not;
include
(module type of Bos.Cmd) with
type t = Bos.Cmd.t;
external%foo bar: string => string;
external%foo bar: int => int = "hello";
let%foo foo: bar;
let%foo foo: bar;
module%foo X: Y;
module%foo X = Y;
module%foo rec X: Y;
let wrapReasonForJs:
(
~component:
componentSpec(
'state,
'initialState,
'retainedProps,
'initialRetainedPropssssssssssssssssss,
'action,
)
) =>
reactClass;
open%foo Bar;
open! %foo Bar;
type%foo t = int;
type%x foo +=
| Int;
module type x = {
let a: 'a. 'a => unit;
};
let a: 'a. 'a => unit;
================================================
FILE: test/generics.t/input.re
================================================
type t = A { a : int } | B;
let f = fun
| B => 0
| A { a } => a;
type nonrec u('a) = Box('a);
type expr('a) =
| Val {value: 'a} :expr('a)
| Add {left: expr(int), right: expr(int)} :expr(int)
| Is0 {test: expr(int)} :expr(bool)
| If {pred: expr(bool), true_branch: expr('a), false_branch: expr('a)} :expr('a);
let rec eval: type a. (expr(a)) => a =
fun(e) =>
switch (e) {
| Is0 {test} => eval(test) == 0
| Val {value} => value
| Add {left, right} => eval(left) + eval(right)
| If {pred, true_branch, false_branch} =>
if (eval(pred)) {
eval(true_branch)
} else {
eval(false_branch)
}
};
type hlist =
| [] : hlist;
let foo (type a, type b) = 5;
================================================
FILE: test/generics.t/run.t
================================================
Format features from OCaml 4.03
$ refmt ./input.re
type t =
| A({a: int})
| B;
let f =
fun
| B => 0
| A({ a }) => a;
type nonrec u('a) =
| Box('a);
type expr('a) =
| Val({value: 'a}): expr('a)
| Add({
left: expr(int),
right: expr(int),
})
: expr(int)
| Is0({test: expr(int)}): expr(bool)
| If({
pred: expr(bool),
true_branch: expr('a),
false_branch: expr('a),
})
: expr('a);
let rec eval: type a. expr(a) => a = e =>
switch (e) {
| Is0({ test }) => eval(test) == 0
| Val({ value }) => value
| Add({ left, right }) =>
eval(left) + eval(right)
| If({ pred, true_branch, false_branch }) =>
if (eval(pred)) {
eval(true_branch);
} else {
eval(false_branch);
}
};
type hlist =
| []: hlist;
let foo = (type a, type b) => 5;
================================================
FILE: test/if.t/input.re
================================================
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
let logTSuccess = fun(self) => if (self > other) {
print_string("Did T");
print_newline ();
} else {
();
};
let something = if (self.ext.logSuccess) {
print_string("Did T");
print_newline ();
};
let logTSuccess = fun(self) => if (self.ext.logSuccess) {
print_string("Did T");
print_newline ();
} else {
();
};
if (if (x) {true;} else {false;}) {
true;
} else {
false;
};
/* Parens are required around if if it's an argument - this is the same as before. */
if (callSomeFunction (if (true) {true;} else {false;})) {
true;
} else {
false;
};
/* Notice that to do something strange, your code must *look* strange. */
/* That's generally a good thing */
if (callSomeFunction) {if (true) {
true;
};} else {
false;
};
if (callSomeFunction {thisIsAnArgument; notTheControlFlow;}) {
thisIsTheControlFlow;
};
/* The braces around the test conditions of if statements are not required.
* The only requirement is that the test conditions be "simple".
* The "then" body only need be simple but the parser will print it as a
* sequence (this is a lossless process - nothing changes about the AST).
*
* The else body doesn't even need to be simple (hence the nesting of else if),
* but the printer will print it inside a simple sequence, unless it
* can make it prettier by nesting the else ifs.
*
*/
if (printIfFirstArgGreater)
simpleThen
else thisDoesnt(even,have2,be,simple);
if (if (x) {true;} else {false;}) {
();
} else {
();
};
/** TERNARY
*============================================================================
*/
let ternaryResult =
something ?
callThisFunction(withThisArg):
thatResult;
let annotatedTernary =
true &&
(something ? true : false : bool);
let annotatedBranch =
true &&
(something ? (true:bool) : false : bool);
/* The following should be... */
let whatShouldThisBeParsedAs =
something ? callThisFunction(withThisArg):
trailingTest ? true : false;
/* ... it should be parsed as */
let whatShouldThisBeParsedAs =
something ? callThisFunction(withThisArg):
(trailingTest ? true : false);
/* Should *not* be parsed as */
let whatShouldThisBeParsedAs =
(something ? callThisFunction(withThisArg):
trailingTest) ? true : false;
/* the following shoud be... */
let ternaryFormatting =
something ? notLongEnoughToCauseTwoLineBreaks : other
/* ideally formatted as
let ternaryFormatting =
something
? notLongEnoughToCauseTwoLineBreaks
: other
*/
let ternaryFormatting =
something
? notLongEnoughToCauseTwoLineBreaks
: other
/* but is currently formatted as the following (which is less than desirable)
let ternaryFormatting =
something
? notLongEnoughToCauseTwoLineBreaks : other
*/
let ternaryFormatting =
something
? notLongEnoughToCauseTwoLineBreaks : other
let ternaryResult =
aaaaaa ? bbbbbbb :
ccccc ? ddddddd :
eeeee ? fffffff : ggggg;
/* Should be parsed as: */
let ternaryResult =
aaaaaa ? bbbbbbb :
(ccccc ? ddddddd :
(eeeee ? fffffff : ggggg));
let ternaryResult =
/* The first Parens *must* be preserved! */
(x ? y : z) ? bbbbbbb :
ccccccc ? ddddddd :
eeeeeee ? fffffff : ggggg;
let ternaryResult =
aaaaaaa ? bbbbbbb :
/* The second Parens *must* be preserved! */
(x ? y : z) ? ddddddd :
eeeeeee ? fffffff : ggggg;
let ternaryResult =
aaaaaaa ? bbbbbbb :
x ? y : z ? ddddddd :
/* The final parent don't need to be preserved */
eeeeeee ? fffffff : (x ? y : z);
let addOne(x) = x + 1;
let result =
addOne(0) + 0 > 1 ? print_string("this wont print") : print_string("this will");
/*
* Should be parsed as:
*/
let result =
((addOne(0) + 0) > 1) ? (print_string("this wont print")) : (print_string("this will"));
/*
* Try shouldn't be aliased as ternary!
*/
let res =
try (something) {
| true => "hi"
| false => "bye"
};
/*
* Many levels of if elseif should be formatted very nicely.
*/
let result =
if (something) {
Console.log ("First Branch");
} else if (anotherThing) {
Console.log ("Second Branch");
} else if (yetAnotherThing) {
Console.log ("Third Branch");
} else {
Console.log ("Final Case");
};
/*
* Ternaries are simply switch statements on true/false. It's nice that there
* is a distinction between if and switch (even though if could have just been
* sugar on top of switch) because it allows us to use switching on true/false
* as yet another pun for if/then that should be *preserved* as being distinct
* from if/then (the ternary).
*/
let res =
switch (someExpression) {
| true => "true"
| false => "false"
};
let pngSuffix =
pixRation > 1 ?
"@" ++ string_of_int(pixRation) ++ "x.png"
: ".png";
================================================
FILE: test/if.t/run.t
================================================
Format if statements
$ refmt ./input.re
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
let logTSuccess = self =>
if (self > other) {
print_string("Did T");
print_newline();
} else {
();
};
let something =
if (self.ext.logSuccess) {
print_string("Did T");
print_newline();
};
let logTSuccess = self =>
if (self.ext.logSuccess) {
print_string("Did T");
print_newline();
} else {
();
};
if (if (x) {true} else {false}) {
true;
} else {
false;
};
/* Parens are required around if if it's an argument - this is the same as before. */
if (callSomeFunction(
if (true) {true} else {false},
)) {
true;
} else {
false;
};
/* Notice that to do something strange, your code must *look* strange. */
/* That's generally a good thing */
if (callSomeFunction) {
if (true) {true};
} else {
false;
};
if (callSomeFunction(
{
thisIsAnArgument;
notTheControlFlow;
},
)) {
thisIsTheControlFlow;
};
/* The braces around the test conditions of if statements are not required.
* The only requirement is that the test conditions be "simple".
* The "then" body only need be simple but the parser will print it as a
* sequence (this is a lossless process - nothing changes about the AST).
*
* The else body doesn't even need to be simple (hence the nesting of else if),
* but the printer will print it inside a simple sequence, unless it
* can make it prettier by nesting the else ifs.
*
*/
if (printIfFirstArgGreater) {
simpleThen;
} else {
thisDoesnt(even, have2, be, simple);
};
if (if (x) {true} else {false}) {
();
} else {
();
};
/** TERNARY
*============================================================================
*/
let ternaryResult =
something
? callThisFunction(withThisArg) : thatResult;
let annotatedTernary =
true && (something ? true : false: bool);
let annotatedBranch =
true
&& (something ? (true: bool) : false: bool);
/* The following should be... */
let whatShouldThisBeParsedAs =
something
? callThisFunction(withThisArg)
: trailingTest ? true : false;
/* ... it should be parsed as */
let whatShouldThisBeParsedAs =
something
? callThisFunction(withThisArg)
: trailingTest ? true : false;
/* Should *not* be parsed as */
let whatShouldThisBeParsedAs =
(
something
? callThisFunction(withThisArg)
: trailingTest
)
? true : false;
/* the following shoud be... */
let ternaryFormatting =
something
? notLongEnoughToCauseTwoLineBreaks : other;
/* ideally formatted as
let ternaryFormatting =
something
? notLongEnoughToCauseTwoLineBreaks
: other
*/
let ternaryFormatting =
something
? notLongEnoughToCauseTwoLineBreaks : other;
/* but is currently formatted as the following (which is less than desirable)
let ternaryFormatting =
something
? notLongEnoughToCauseTwoLineBreaks : other
*/
let ternaryFormatting =
something
? notLongEnoughToCauseTwoLineBreaks : other;
let ternaryResult =
aaaaaa
? bbbbbbb
: ccccc ? ddddddd : eeeee ? fffffff : ggggg;
/* Should be parsed as: */
let ternaryResult =
aaaaaa
? bbbbbbb
: ccccc ? ddddddd : eeeee ? fffffff : ggggg;
let ternaryResult =
/* The first Parens *must* be preserved! */
(x ? y : z)
? bbbbbbb
: ccccccc
? ddddddd : eeeeeee ? fffffff : ggggg;
let ternaryResult =
aaaaaaa
? bbbbbbb
/* The second Parens *must* be preserved! */
: (x ? y : z)
? ddddddd : eeeeeee ? fffffff : ggggg;
let ternaryResult =
aaaaaaa
? bbbbbbb
: x
? y
: z
? ddddddd
/* The final parent don't need to be preserved */
: eeeeeee ? fffffff : x ? y : z;
let addOne = x => x + 1;
let result =
addOne(0) + 0 > 1
? print_string("this wont print")
: print_string("this will");
/*
* Should be parsed as:
*/
let result =
addOne(0) + 0 > 1
? print_string("this wont print")
: print_string("this will");
/*
* Try shouldn't be aliased as ternary!
*/
let res =
try(something) {
| true => "hi"
| false => "bye"
};
/*
* Many levels of if elseif should be formatted very nicely.
*/
let result =
if (something) {
Console.log("First Branch");
} else if (anotherThing) {
Console.log("Second Branch");
} else if (yetAnotherThing) {
Console.log("Third Branch");
} else {
Console.log("Final Case");
};
/*
* Ternaries are simply switch statements on true/false. It's nice that there
* is a distinction between if and switch (even though if could have just been
* sugar on top of switch) because it allows us to use switching on true/false
* as yet another pun for if/then that should be *preserved* as being distinct
* from if/then (the ternary).
*/
let res = someExpression ? "true" : "false";
let pngSuffix =
pixRation > 1
? "@" ++ string_of_int(pixRation) ++ "x.png"
: ".png";
/* Parens are required around if if it's an argument - this is the same as before. */
================================================
FILE: test/imperative.t/input.re
================================================
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
/*
* Syntax and fallback syntax.
* vim: set ft=reason:
*/
switch (while (true) {
();
}) {
| _ => ()
};
try (while (true) {
();
}) {
| _ => ()
};
switch (for (i in 0 to 10) {
();
}) {
| _ => ()
};
try (for (i in 0 to 10) {
();
}) {
| _ => ()
};
switch (
if (true) {print_string("switching on true");} else {print_string("switching on false");}
) {
| _ => ()
};
try (for (i in 0 to 10) {
();
}) {
| _ => ()
};
let result = while (false) {
();
} == () ? false : true;
switch (
try (
try () { | _ => () }
) {
| _ => ()
}
) {
| () => ()
};
let shouldStillLoop = {contents: false};
while (shouldStillLoop.contents) {
print_string("You're in a while loop");
print_newline();
};
while {
shouldStillLoop.contents = false;
shouldStillLoop.contents;
} {
print_string("Will never loop");
};
while ((shouldStillLoop := false) == ()) {
print_string("Forever in the loop");
};
================================================
FILE: test/imperative.t/run.t
================================================
Format basic
$ refmt --print re ./input.re > ./formatted.re
Print the formatted file
$ cat ./formatted.re
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
/*
* Syntax and fallback syntax.
* vim: set ft=reason:
*/
switch (
while (true) {
();
}
) {
| _ => ()
};
try(
while (true) {
();
}
) {
| _ => ()
};
switch (
for (i in 0 to 10) {
();
}
) {
| _ => ()
};
try(
for (i in 0 to 10) {
();
}
) {
| _ => ()
};
switch (
if (true) {
print_string("switching on true");
} else {
print_string("switching on false");
}
) {
| _ => ()
};
try(
for (i in 0 to 10) {
();
}
) {
| _ => ()
};
let result =
(
while (false) {
();
}
)
== ()
? false : true;
switch (
try(
try() {
| _ => ()
}
) {
| _ => ()
}
) {
| () => ()
};
let shouldStillLoop = { contents: false };
while (shouldStillLoop.contents) {
print_string("You're in a while loop");
print_newline();
};
while ({
shouldStillLoop.contents = false;
shouldStillLoop.contents;
}) {
print_string("Will never loop");
};
while ((shouldStillLoop := false) == ()) {
print_string("Forever in the loop");
};
Type-check basics
$ ocamlc -c -pp 'refmt --print binary' -intf-suffix .rei -impl formatted.re
Format the formatted file back
$ refmt --print re ./formatted.re > ./formatted_back.re
Ensure idempotency: first format and second format are the same
$ diff formatted.re formatted_back.re
================================================
FILE: test/infix.t/input.re
================================================
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
/* - A good way to test if formatting of infix operators groups precedences
correctly, is to write an expression twice. Once in a form where parenthesis
explicitly group according to the parse tree and write it another time
without any parenthesis. After formatting, the two should be equal
textually.
- Reformatting n > 0 times should be idempotent.
- Our formatting algorithm *could* decide to leave equivalently precedented
infix applications ungrouped in parenthesis (which is what the above test
verifies), but the additional parenthesis is nice. */
/* < > = all have same precedence level/direction(left) */
let parseTree = ((x > y > z) < a < b) == c == d;
let minParens = ((x > y > z) < a < b) == c == d;
let formatted = ((x > y > z) < a < b) == c == d;
/* Case with === */
let parseTree = ((x > y > z) < a < b) === c === d;
let minParens = ((x > y > z) < a < b) === c === d;
let formatted = ((x > y > z) < a < b) === c === d;
/* < > = all have same precedence level and direction (left) */
let parseTree = a1 < a2 < (b1 > b2 > (y == x == z));
let minParens = a1 < a2 < (b1 > b2 > (y == x == z));
let formatted = a1 < a2 < (b1 > b2 > (y == x == z));
/* Case with === */
let parseTree = a1 < a2 < (b1 > b2 > (y === x === z));
let minParens = a1 < a2 < (b1 > b2 > (y === x === z));
let formatted = a1 < a2 < (b1 > b2 > (y === x === z));
/* !=...(left) same level =(left) is higher than :=(right) */
let parseTree = a1 := a2 := b1 == b2 == (y != x != z);
let minParens = a1 := a2 := b1 == b2 == (y != x != z);
let formatted = a1 := a2 := b1 == b2 == (y != x != z);
/* Case with === */
let parseTree = a1 := a2 := b1 === b2 === (y !== x !== z);
let minParens = a1 := a2 := b1 === b2 === (y !== x !== z);
let formatted = a1 := a2 := b1 === b2 === (y !== x !== z);
/* !=...(left) same level =(left) is higher than :=(right) */
let parseTree = a1 := a2 := b1 == ((b2 == y) != x != z);
let minParens = a1 := a2 := b1 == ((b2 == y) != x != z);
let formatted = a1 := a2 := b1 == ((b2 == y) != x != z);
/* Case with === */
let parseTree = a1 := a2 := b1 === ((b2 === y) !== x !== z);
let minParens = a1 := a2 := b1 === ((b2 === y) !== x !== z);
let formatted = a1 := a2 := b1 === ((b2 === y) !== x !== z);
/* &...(left) is higher than &(right). &(right) is equal to &&(right) */
let parseTree = a1 && (a2 && (b1 & b2 & y &|| x &|| z));
let minParens = a1 && a2 && (b1 & b2 & y &|| x &|| z);
let formatted = a1 && a2 && (b1 & b2 & y &|| x &|| z);
/**
* Now, let's try an example that resembles the above, yet would require
* parenthesis everywhere.
*/
/* &...(left) is higher than &(right). &(right) is equal to &&(right) */
let parseTree = ((((a1 && a2) && b1) & b2) & y) &|| (x &|| z);
let minParens = ((((a1 && a2) && b1) & b2) & y) &|| (x &|| z);
let formatted = ((((a1 && a2) && b1) & b2) & y) &|| (x &|| z);
/* **...(right) is higher than *...(left) */
let parseTree = ((b1 *| b2) *| (y *\*| (x *\*| z)));
let minParens = b1 *| b2 *| y *\*| x *\*| z;
let formatted = b1 *| b2 *| y *\*| x *\*| z;
/* **...(right) is higher than *...(left) */
let parseTree = ((b1 *| b2) *| (y *\*| ((x *\*| z) *| a)));
let minParens = b1 *| b2 *| y *\*| (x *\*| z *| a);
let formatted = b1 *| b2 *| y *\*| (x *\*| z *| a);
/* |...(left) is higher than ||(right) */
/* All parens should be removed when formatting n > 0 times */
let parseTree = b1 || b2 || y |\* x |\* z;
let minParens = b1 || b2 || y |\* x |\* z;
let formatted = b1 || b2 || y |\* x |\* z;
/* Associativity effects how parenthesis should be dropped */
/* This one *shouldn't* expand into two consecutive infix + */
first + (second + third);
/* This one *should* */
first + second + third;
/* But that's just because + is left associative. Since & is right associative,
* it's the opposite. */
/* This one *should* expand into two consecutive infix * */
first & second & third;
/* This one *shouldn't* */
(first & second) & third;
/* || is basically the same as &/&& */
first || second || third;
/* This one *shouldn't* */
(first || second) || third;
/* No parens should be added/removed from the following when formatting */
let seeWhichCharacterHasHigherPrecedence = (first |> second |> third) ^> fourth;
let seeWhichCharacterHasHigherPrecedence = first |> second |> third;
let seeWhichCharacterHasHigherPrecedence = first + second + third;
let comparison = (==);
/* Why would the following two cases have different grouping? */
let res = blah || DataConstructor(10) || DataConstructor(10) && 10;
let res = blah && DataConstructor(10) && DataConstructor(10) + 10;
/* This demonstrates how broken infix pretty printing is:
*/
let curriedComparison = (==)(10);
let resultOfAdd = 10 + 20 + 40;
let resultOfAddAndMult = 10 * 1 + 20 * 1 + 40 * 1;
let greaterThanAndSubtract = 1 - 2 > 4 + 3;
let greaterThanAndFunctionCalls = pred(1) > pred(2);
let lessThanAndFunctionCalls = pred(1) < pred(2);
/* This doesn't type check because it looks like pred - 1 */
let minusAndInteger = pred - 1;
let passingMinusOneToFunction = pred (-1);
let leadingMinusIsCorrectlyNeg = (-1) + 20;
let leadingMinusIsCorrectlyNeg = 3 > (-1);
/* Custom infix without labeled args */
let (|>)(first,second) = first + second;
/* Should reformat to actually be placed infix */
let res = first |> second;
/* Curried shouldn't place infix */
let res = (|>)(first);
/* Custom infix with labeled args */
let (|>)(~first as first, ~second as second) = first + second;
/* Should NOT reformat named args to actually be placed infix */
let res = (|>)(~first=first, ~second=second);
/* Curried shouldn't place infix */
let res = (|>)(~first=first);
/* Custom infix accepting *three* without labeled args */
let (|>)(firsfirst,second,third) = first + second + third;
/* Should reformat to actually be placed infix if passed two args */
let res = first |> second;
let res = (first |> second)(third);
/* Should NOT reformat to be placed infix if passed all three */
let res = (|>)(first,second,third);
/* Same: Curried shouldn't place infix */
let res = (|>)(first);
/* In fact, if even just one of the arguments are named, it shouldn't
* be formatted or parsed as infix! */
(|>)(first,~second=second);
(|>)(~first=first,second);
(|>)(first,second,~third=third);
(first |> second)(~third=third);
/* Infix has lower precedence than function application */
first |> second(~third=third);
let leftAssocGrouping = first |> second |> third;
let rightAssocGrouping = first ^> second ^> third;
/* It's definitely the caret. */
let seeWhichCharacterHasHigherPrecedence = first |> second ^> third;
let seeWhichCharacterHasHigherPrecedence = first ^> second |> third;
let seeWhichCharacterHasHigherPrecedence = first ^> (second |> third) |> fourth;
let res = blah && DataConstructor(10) && DataConstructor(10) + 10;
/* Should be parsed as */
let res = blah && DataConstructor(10) && DataConstructor(10) + 10;
let (++)(~label as label,~label2 as label2) = label + label2;
let (++)(~label as label,~label2 as label2) = label + label2;
let (++) = (++);
let (++): int = int = (++);
(++)(~label=20, ~label2=30) + 40;
/* Should be parsed as: */
(++)(~label=20, ~label2=30) + 40;
/* Great idea! */
let (==)(a,b) = a < 0;
let (==)(a,b) = a < 0;
let (==) = (==);
let (==): int = int = (==);
let equal = Pervasives.(==);
let starInfix_makeSureSpacesSurround = ( * );
let starInfix_makeSureSpacesSurround = ( *\*\* );
/* The following two should be equivalently parsed/printed. */
let includesACommentCloseInIdentifier = ( *\*\/ );
let includesACommentCloseInIdentifier = ( *\*\/ );
let shouldSimplifyAnythingExceptApplicationAndConstruction = call("hi") ++ (switch (x) {
| _ => "hi"
}) ++ "yo";
let shouldRemoveParens = (ident + ident) + ident;
let shouldRemoveParens = ident ++ (ident ++ ident);
let shouldPreserveParens = ident + (ident + ident);
let shouldPreserveParens = (ident ++ ident) ++ ident;
/**
* Since ++ is now INFIXOP1, it should have lower priority than INFIXOP2 (which
* includes the single plus sign). That means no parens are required in the
* following scenario even though they'd be required in (ident ++ ident) ++ ident.
*/
let noParensRequired = ident + ident ++ ident;
/* So in this case, it should format to whatever the previous example formats to. */
let noParensRequired = (ident + ident) ++ ident;
/**
* Everything that was said above should be true of minus sign as well. In
* terms of precedence, plus sign should be treated the same as plus sign
* followed by a dollar sign. And +++ should be treated the same as ++.
* should also be true of plus sign followed by dollar sign for example.
*/
let shouldRemoveParens = (ident - ident) - ident;
let shouldPreserveParens = ident - (ident - ident);
let shouldPreserveParens = ident +$ (ident +$ ident);
let noParensRequired = ident - ident ++ ident;
let noParensRequired = (ident - ident) ++ ident;
let noParensRequired = (ident +$ ident) ++ ident;
let noParensRequired = ident + ident +++ ident;
let noParensRequired = (ident + ident) +++ ident;
/* Parens are required any time you want to make ++ or +++ parse with higher
* priority than + or - */
let parensRequired = ident + (ident ++ ident);
let parensRequired = ident + (ident +++ ident);
let parensRequired = ident + (ident ++- ident);
let parensRequired = ident +$ (ident ++- ident);
/* ++ and +++ have the same parsing precedence, so it's right associative.
* Parens are required if you want to group to the left, even when the tokens
* are different.*/
let parensRequired = (ident ++ ident) +++ ident;
let parensRequired = (ident +++ ident) ++ ident;
/* Add tests with IF/then mixed with infix/constructor application on left and right sides */
/**
* Every star or forward slash after the character of an infix operator must be
* escaped.
*/
let ( /\* )(a,b) = a + b;
let x = 12 /-\* 23 /-\* 12;
let y = a /\* b;
let ( !=\* )(q,r) = q + r;
let res = q(( !=\* ),r);
let ( !=\/\* )(q,r) = q + r;
let res = q(( !=\/\* ),r);
let ( ~\* )(a) = a + 1;
let res = ~\*10;
let res = f - - x;
let res = f - (- x);
let res = - (- x);
let res = f (- x);
/**
* Test using almost simple prefix as regular function.
*/
let (!!)(a,b) = a + b;
let res = (!!)(20,40);
/* The semicolon should be attached to someType */
let myFunc(aaaa,bbbb,cccc,dddd,aaaa,bbbb,cccc,dddd,aaaa) =
[blah(aaaa,bbbb,cccc,dddd,aaaa,bbbb,cccc,dddd,aaaa), ...someType];
/**
* Testing various fixity.
*/
/**
* For each of these test cases for imperative updates, we'll test both record
* update, object member update and array update.
*/
let containingObject = {
val mutable y = 0;
val arr = [|true, false, false|];
val bigArr = "goodThingThisIsntTypeChecked";
val str = "string";
pub testCases () {
/**
* The lowest precedence token is =, followed by :=, and then ?, then :.
*
* The following text
*
* x.contents = tenaryTest ? ifTrue : ifFalse
*
* Generates the following parse tree:
*
* =
* / \
* / \
* record ternary
*
* Because when encountering the ? the parser will shift on the ? instead of
* reducing expr = expr
*/
/**
* Without a + 1
*/
x.contents = something ? hello : goodbye;
y = something ? hello : goodbye;
arr[0] = something ? hello : goodbye;
bigArr.{0} = something ? hello : goodbye;
str.[0] = something ? hello : goodbye;
(x.contents = something) ? hello : goodbye;
(y = something) ? hello : goodbye;
(arr[0] = something) ? hello : goodbye;
(bigArr.{0} = something) ? hello : goodbye;
(str.[0] = something) ? hello : goodbye;
x.contents = (something ? hello : goodbye);
y = (something ? hello : goodbye);
arr[0] = (something ? hello : goodbye);
bigArr.{0} = (something ? hello : goodbye);
str.[0] = (something ? hello : goodbye);
/**
* With a + 1
*/
x.contents = something + 1 ? hello : goodbye;
x := something + 1 ? hello : goodbye;
y = something + 1 ? hello : goodbye;
arr[0] = something + 1 ? hello : goodbye;
bigArr.{0} = something + 1 ? hello : goodbye;
str.[0] = something + 1 ? hello : goodbye;
(x.contents = something + 1) ? hello : goodbye;
(x := something + 1) ? hello : goodbye;
(y = something + 1) ? hello : goodbye;
(arr[0] = something + 1) ? hello : goodbye;
(bigArr.{0} = something + 1) ? hello : goodbye;
(str.[0] = something + 1) ? hello : goodbye;
x.contents = (something + 1 ? hello : goodbye);
x := (something + 1 ? hello : goodbye);
y = (something + 1 ? hello : goodbye);
arr[0] = (something + 1 ? hello : goodbye);
bigArr.{0} = (something + 1 ? hello : goodbye);
str.[0] = (something + 1 ? hello : goodbye);
/**
* #NotActuallyAConflict
* Note that there's a difference with how = and := behave.
* We only *simulate* = being an infix identifier for the sake of printing,
* but for parsing it's a little more nuanced. There *isn't* technically a
* shift/reduce conflict in the following that must be resolved via
* precedence ranking:
*
* a + b.c = d
*
* No conflict between reducing a + b.c, and shifting =, like there would
* be if it was := instead of =. That's because the rule for = isn't the
* infix rule with an arbitrary expression on its left - it's something
* much more specific.
*
* (simple_expr) DOT LIDENT EQUAL expression.
*
* So with the way yacc/menhir works, when it sees an equal sign, it knows
* that there is no valid parse where a + b.c is reduced to an expression
* with an = immediately appearing after, so it shifts the equals.
*
* If you replace = with :=, you'd see different behavior.
*
* a + b.c := d
*
* Since := has lower precedence than +, it would be parsed as:
*
* (a + b.c) := d
*
* However, our printing logic will print = assignment with parenthesis:
*
* a + (b.c = d)
*
* Even though they're not needed, because it doesn't know details about
* which rules are valid, we just told it to print = as if it were a valid
* infix identifier.
*
* Another case:
*
* something >>= fun x => x + 1;
*
* Will be printed as:
*
* something >>= (fun x => x + 1);
*
* Because the arrow has lower precedence than >>=, but it wasn't needed because
*
* (something >>= fun x) => x + 1;
*
* Is not a valid parse. Parens around the `=>` weren't needed to prevent
* reducing instead of shifting. To optimize this part, we need a much
* deeper encoding of the parse rules to print parens only when needed.
*
*/
/* The following */
x + something.contents = y;
x + something = y;
x + something.contents := y;
x + something := y;
/* Should be parsed as: */
x + (something.contents = y); /* Because of the #NotActuallyAConflict above */
x + (something = y); /* Same */
(x + something.contents) := y;
(x + something) := y;
/* To make the := parse differently, we must use parens */
x + (something.contents := y);
x + (something := y);
/**
* Try with ||
*/
x.contents || something + 1 ? hello : goodbye;
y || something + 1 ? hello : goodbye;
arr[0] || something + 1 ? hello : goodbye;
bigArr.{0} || something + 1 ? hello : goodbye;
str.[0] || something + 1 ? hello : goodbye;
(x.contents || something + 1) ? hello : goodbye;
(y || something + 1) ? hello : goodbye;
(arr[0] || something + 1) ? hello : goodbye;
(bigArr.{0} || something + 1) ? hello : goodbye;
(str.[0] || something + 1) ? hello : goodbye;
x.contents || (something + 1 ? hello : goodbye);
y || (something + 1 ? hello : goodbye);
arr[0] || (something + 1 ? hello : goodbye);
bigArr.{0} || (something + 1 ? hello : goodbye);
str.[0] || (something + 1 ? hello : goodbye);
/**
* Try with &&
*/
x.contents && something + 1 ? hello : goodbye;
y && something + 1 ? hello : goodbye;
arr[0] && something + 1 ? hello : goodbye;
bigArr.{0} && something + 1 ? hello : goodbye;
str.[0] && something + 1 ? hello : goodbye;
(x.contents && something + 1) ? hello : goodbye;
(y && something + 1) ? hello : goodbye;
(arr[0] && something + 1) ? hello : goodbye;
(bigArr.{0} && something + 1) ? hello : goodbye;
(str.[0] && something + 1) ? hello : goodbye;
x.contents && (something + 1 ? hello : goodbye);
y && (something + 1 ? hello : goodbye);
arr[0] && (something + 1 ? hello : goodbye);
bigArr.{0} && (something + 1 ? hello : goodbye);
str.[0] && (something + 1 ? hello : goodbye);
/**
* See how regular infix operators work correctly.
*/
x.contents = (2 + 4);
y = (2 + 4);
arr[0] = (2 + 4);
bigArr.{0} = (2 + 4);
str.[0] = (2 + 4);
(x.contents = 2) + 4;
(y = 2) + 4;
(arr[0] = 2) + 4;
(bigArr.{0} = 2) + 4;
(str.[0] = 2) + 4;
/**
* Ensures that record update, object field update, and := are all right
* associative.
*/
x.contents = y.contents = 10;
y = x.contents = 10;
arr[0] = x.contents = 10;
bigArr.{0} = x.contents = 10;
str.[0] = x.contents = 10;
/* Should be the same as */
x.contents = (x.contents = 10);
y = (x.contents = 10);
arr[0] = (x.contents = 10);
bigArr.{0} = (x.contents = 10);
str.[0] = (x.contents = 10);
/**
* Ensures that record update, object field update, and := are all right
* associative.
*/
x := x := 10;
/* Should be the same as */
x := (x := 10);
/* By default, without parens*/
x ? y : z ? a : b;
/* It is parsed as the following: */
x ? y : (z ? a : b);
/* Not this: */
(x ? y : z) ? a : b;
/**
* ^
* When rendering the content to the left of the ? we know that we want the
* parser to reduce the thing to the left of the ? when the ? is seen. So we
* look at the expression to the left of ? and discover what precedence level
* it is (token of its rightmost terminal). We then compare it with ? to see
* who would win a shift reduce conflict. We want the term to the left of the ?
* to be reduced. So if it's rightmost terminal isn't higher precedence than ?,
* we wrap it in parens.
*/
/***
* The following
*/
x.contents = something ? x.contents = somethingElse : goodbye;
y = something ? y = somethingElse : goodbye;
arr[0] = something ? arr[0] = somethingElse : goodbye;
bigArr.{0} = something ? bigArr.{0} = somethingElse : goodbye;
str.[0] = something ? str.[0] = somethingElse : goodbye;
/*
* Should be parsed as
*/
x.contents = (something ? x.contents = somethingElse : goodbye);
y = (something ? y = somethingElse : goodbye);
arr[0] = (something ? arr[0] = somethingElse : goodbye);
bigArr.{0} = (something ? bigArr.{0} = somethingElse : goodbye);
str.[0] = (something ? str.[0] = somethingElse : goodbye);
/** And this */
y := something ? y := somethingElse : goodbye;
arr[0] := something ? arr[0] := somethingElse : goodbye;
bigArr.{0} := something ? bigArr.{0} := somethingElse : goodbye;
str.[0] := something ? str.[0] := somethingElse : goodbye;
/* Should be parsed as */
y := (something ? (y := somethingElse) : goodbye);
arr[0] := (something ? (arr[0] := somethingElse) : goodbye);
bigArr.{0} := (something ? (bigArr.{0} := somethingElse) : goodbye);
str.[0] := (something ? (str.[0] := somethingElse) : goodbye);
/* The following */
x := something ? x.contents = somethingElse ? goodbye : goodbye : goodbye;
x := something ? arr[0] = somethingElse ? goodbye : goodbye : goodbye;
x := something ? bigArr.{0} = somethingElse ? goodbye : goodbye : goodbye;
x := something ? str.[0] = somethingElse ? goodbye : goodbye : goodbye;
/* Is parsed as */
x := (something ? x.contents = (somethingElse ? goodbye : goodbye) : goodbye);
x := (something ? arr[0] = (somethingElse ? goodbye : goodbye) : goodbye);
x := (something ? bigArr.{0} = (somethingElse ? goodbye : goodbye) : goodbye);
x := (something ? str.[0] = (somethingElse ? goodbye : goodbye) : goodbye);
/* is not the same as */
x := something ? (x.contents = somethingElse) ? goodbye : goodbye : goodbye;
x := something ? (arr[0] = somethingElse) ? goodbye : goodbye : goodbye;
x := something ? (bigArr.{0} = somethingElse) ? goodbye : goodbye : goodbye;
x := something ? (str.[0] = somethingElse) ? goodbye : goodbye : goodbye;
/**
* And
*/
/** These should be parsed the same */
something ? somethingElse : x.contents = somethingElse ? x : z;
something ? somethingElse : (x.contents = (somethingElse ? x : z));
/* Not: */
something ? somethingElse : (x.contents = somethingElse) ? x : z;
(something ? somethingElse : (x.contents = somethingElse)) ? x : z;
/* These should be parsed the same */
something ? somethingElse : x := somethingElse ? x : z;
something ? somethingElse : (x := (somethingElse ? x : z));
/* Not: */
something ? somethingElse : (x := somethingElse) ? x : z;
(something ? somethingElse : (x := somethingElse)) ? x : z;
/** These should be parsed the same */
something ? somethingElse : y = somethingElse ? x : z;
something ? somethingElse : (y = (somethingElse ? x : z));
/* Not: */
something ? somethingElse : (y = somethingElse) ? x : z;
(something ? somethingElse : (y = somethingElse)) ? x : z;
/** These should be parsed the same */
something ? somethingElse : arr[0] = somethingElse ? x : arr[0];
something ? somethingElse : (arr[0] = (somethingElse ? x : arr[0]));
/* Not: */
something ? somethingElse : (arr[0] = somethingElse) ? x : z;
(something ? somethingElse : (arr[0] = somethingElse)) ? x : z;
/** These should be parsed the same */
something ? somethingElse : bigArr.{0} = somethingElse ? x : bigArr.{0};
something ? somethingElse : (bigArr.{0} = (somethingElse ? x : bigArr.{0}));
/* Not: */
something ? somethingElse : (bigArr.{0} = somethingElse) ? x : z;
(something ? somethingElse : (bigArr.{0} = somethingElse)) ? x : z;
/** These should be parsed the same */
something ? somethingElse : arr.[0] = somethingElse ? x : arr.[0];
something ? somethingElse : (arr.[0] = (somethingElse ? x : arr.[0]));
/* Not: */
something ? somethingElse : (str.[0] = somethingElse) ? x : z;
(something ? somethingElse : (str.[0] = somethingElse)) ? x : z;
/**
* It creates a totally different meaning when parens group the :
*/
x.contents = something ? (x.contents = somethingElse : x) : z;
y = something ? (y = somethingElse : x) : z;
arr[0] = something ? (arr[0] = somethingElse : x) : z;
bigArr.{0} = something ? (bigArr.{0} = somethingElse : x) : z;
str.[0] = something ? (str.[0] = somethingElse : x) : z;
/**
* Various precedence groupings.
*/
true ? true ? false : false : false;
/* Is the same as */
true ? (true ? false : false) : false;
/*
* Just some examples of how prefix will be printed.
*/
- x + something.contents = y;
- x + something = y;
- x + something.contents := y;
- x + something := y;
x + - something.contents = y;
x + - something = y;
x + - something.contents := y;
x + - something := y;
x.contents || something + 1 ? - hello : goodbye;
bigArr.{0} || - something + 1 ? hello : goodbye;
let result = - x + something.contents = y;
/* Prefix minus is actually sugar for regular function identifier ~-*/
let result = 2 + (~-) (add(4,0));
/* Same as */
let result = 2 + ~- add(4,0);
/* Same as */
let result = 2 + - add(4,0);
/* That same example but with ppx attributes on the add application */
let result = 2 + (~-) ([@ppx] add(4,0));
/* Same as */
let result = [@ppx] 2 + ~- add(4,0);
/* Same as */
let result = [@ppx] 2 + - add(4,0);
/* Multiple nested prefixes */
let result = 2 + - - - add(4,0);
/* And with attributes */
let result = [@onAddApplication] 2 + - - - add(4,0);
/**
* TODO: Move all of these test cases to attributes.re.
*/
/* Attribute on the prefix application */
let res = [@attr] (- something(blah,blah));
/* Attribute on the regular function application, not prefix */
let res = [@attr] - something(blah,blah);
let attrOnPrefix = [@ppxOnPrefixApp] (- 1);
let attrOnPrefix = 5 + - 1;
let result = [@ppxAttributeOnSugarGetter] arr.[0];
/**
* Unary plus/minus has lower precedence than prefix operators:
* And unary plus has same precedence as unary minus.
*/
let res = - !record;
/* Should be parsed as: */
let res = - (! record);
/* Although that precedence ranking doesn't likely have any effect in that
* case. */
/**
* And this
*/
let res = - + callThisFunc ();
/* should be parsed as: */
let res = - + callThisFunc ();
/**
* And this
*/
let res = ! (- callThisFunc ());
/* Should be parsed (and should remain printed as: */
let res = ! (- callThisFunc ());
let res = [@onApplication] !x;
let res = !([@onX] x);
let res = !([@onX] x);
[@shouldBeRenderedOnEntireSetField] (something.contents = "newvalue");
something.contents = [@shouldBeRenderedOnString] "newvalue";
};
};
let x = foo |> z;
let x = foo |> f |> g;
let x = foo |> somelongfunctionname("foo") |> anotherlongfunctionname("bar", 1) |> somelongfunction |> bazasdasdad;
let code = JSCodegen.Code.(
create
|> lines(Requires.(
create
|> import_type(~local="Set", ~source="Set")
|> import_type(~local="Map", ~source="Map")
|> import_type(~local="Immutable", ~source="immutable")
|> require(~local="invariant", ~source="invariant")
|> require(~local="Image", ~source="Image.react")
|> side_effect(~source="monkey_patches")
|> render_lines
))
|> new_line
|> new_line
|> new_line
|> new_line
|> render
);
let code = JSCodegen.Code.(create |> render);
let server = {
let callback(_conn, req, body) = {
let uri = req |> Request.uri |> Uri.to_string |> Code.string_of_uri |> Server.respond |> Request.uri;
let meth = req |> Request.meth |> Code.string_of_method;
let headers = req |> Request.headers |> Header.to_string;
body |> Cohttp_lwt_body.to_string >|= ((body) => {
Printf.sprintf("okokok", uri, meth, headers, body)}) >>= ((body) => Server.respond_string(~status, ~body, ()));
};
Server.create(~mode, Server.make(~callback, ()));
};
let lijst =
List.length
@@ List.map(
(s) => s ++ " example",
[
"one",
"two",
"three",
"four",
"five",
"six",
"seven",
"eight",
"nine",
"ten"
]
);
let example =
true != false
&& "a" == "b"
&& "arbitrary" === "example"
&& "how long" >= "can you get"
&& "seriously" <= "what is the line length";
if (List.length(files)
> 0
&& List.length(otherfiles)
< 2) {
()
};
/* Don't clash with jsx edge cases */
let (=<) = (a, b) => a + b;
let result = x =< y;
let z = x =<
y;
let z = x =<
y;
let (></) = (a, b) => a - b;
let result = x ></ b;
let z = x ></
b;
let z = x ></
b;
let (=</>) = (a, b) => a + b;
let result = x =</> b;
let z = x =</>
b;
let z = x =</>
b;
/* #1676: Exponentiation should be right-associative */
let foo = (100. /. 2.) ** 2. +. (200. /. 2.) ** 2.;
let foo = 100. /. 2. ** 2. +. 200. /. 2. ** 2.;
let x = y />> f;
let (/>>) = (a, b) => a + b;
let x = y />/> f;
let (/>/>) = (a, b) => a + b;
let (><) = (a, b) => a + b;
let x = a >< b;
let (=-) = (a, b) => a + b;
let foo = (a, b) => a =- b;
let (=><) = (a, b) => a + b;
let x = a =>< b;
let foo =
fun
| None => x >>= y
| Some(x) => x >>= y;
something
>>= (
fun
| None => x >>= y
| Some(x) => x >>= y
);
(fun
| None => x >>= y
| Some(x) => x >>= y)
>>= bar ;
something >>=
fun
| None => x >>= y
| Some(x) => x >>= y;
something ?
a >>= (
fun
| None => x >>= y
| Some(x) => x >>= y
) : (
fun
| None => x >>= y
| Some(x) => x >>= y
);
something ?
a >>= (
fun
| None => x >>= y
| Some(x) => x >>= y
) : (
fun
| None => x >>= y
| Some(x) => x >>= y
) >>= b;
let foo =
fun
| None => ()
| Some(x) => fun | None => () | Some(_) => ();
let foo =
fun
| Some(x) => (fun | None => () | Some(_) => ())
| None => ();
let predicate =
predicate === Functions.alwaysTrue1 ?
(fun
| None => false
| Some(exn) => predicate(exn)) >>= foo :
(fun
| None => false
| Some(exn) => predicate(exn));
let predicate =
predicate === Functions.alwaysTrue1 ?
(fun
| None => false
| Some(exn) => predicate(exn)) >>= foo :
bar >>= (fun
| None => false
| Some(exn) => predicate(exn));
let (>...) = (a, b) => a + b;
a >... b;
/* https://github.com/facebook/reason/issues/2169 */
let not = (x) => !x;
let other = (x) => not(x);
let derefInsideArray = [|a^|];
/* https://github.com/facebook/reason/issues/126 */
foo^^;
let x = foo^^;
foo^^bar;
================================================
FILE: test/infix.t/run.t
================================================
Format infix operators
$ refmt ./input.re
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
/* - A good way to test if formatting of infix operators groups precedences
correctly, is to write an expression twice. Once in a form where parenthesis
explicitly group according to the parse tree and write it another time
without any parenthesis. After formatting, the two should be equal
textually.
- Reformatting n > 0 times should be idempotent.
- Our formatting algorithm *could* decide to leave equivalently precedented
infix applications ungrouped in parenthesis (which is what the above test
verifies), but the additional parenthesis is nice. */
/* < > = all have same precedence level/direction(left) */
let parseTree = x > y > z < a < b == c == d;
let minParens = x > y > z < a < b == c == d;
let formatted = x > y > z < a < b == c == d;
/* Case with === */
let parseTree = x > y > z < a < b === c === d;
let minParens = x > y > z < a < b === c === d;
let formatted = x > y > z < a < b === c === d;
/* < > = all have same precedence level and direction (left) */
let parseTree =
a1 < a2 < (b1 > b2 > (y == x == z));
let minParens =
a1 < a2 < (b1 > b2 > (y == x == z));
let formatted =
a1 < a2 < (b1 > b2 > (y == x == z));
/* Case with === */
let parseTree =
a1 < a2 < (b1 > b2 > (y === x === z));
let minParens =
a1 < a2 < (b1 > b2 > (y === x === z));
let formatted =
a1 < a2 < (b1 > b2 > (y === x === z));
/* !=...(left) same level =(left) is higher than :=(right) */
let parseTree =
a1 := a2 := b1 == b2 == (y != x != z);
let minParens =
a1 := a2 := b1 == b2 == (y != x != z);
let formatted =
a1 := a2 := b1 == b2 == (y != x != z);
/* Case with === */
let parseTree =
a1 := a2 := b1 === b2 === (y !== x !== z);
let minParens =
a1 := a2 := b1 === b2 === (y !== x !== z);
let formatted =
a1 := a2 := b1 === b2 === (y !== x !== z);
/* !=...(left) same level =(left) is higher than :=(right) */
let parseTree =
a1 := a2 := b1 == (b2 == y != x != z);
let minParens =
a1 := a2 := b1 == (b2 == y != x != z);
let formatted =
a1 := a2 := b1 == (b2 == y != x != z);
/* Case with === */
let parseTree =
a1 := a2 := b1 === (b2 === y !== x !== z);
let minParens =
a1 := a2 := b1 === (b2 === y !== x !== z);
let formatted =
a1 := a2 := b1 === (b2 === y !== x !== z);
/* &...(left) is higher than &(right). &(right) is equal to &&(right) */
let parseTree =
a1 && a2 && b1 & b2 & y &|| x &|| z;
let minParens =
a1 && a2 && b1 & b2 & y &|| x &|| z;
let formatted =
a1 && a2 && b1 & b2 & y &|| x &|| z;
/**
* Now, let's try an example that resembles the above, yet would require
* parenthesis everywhere.
*/
/* &...(left) is higher than &(right). &(right) is equal to &&(right) */
let parseTree =
((((a1 && a2) && b1) & b2) & y) &|| (x &|| z);
let minParens =
((((a1 && a2) && b1) & b2) & y) &|| (x &|| z);
let formatted =
((((a1 && a2) && b1) & b2) & y) &|| (x &|| z);
/* **...(right) is higher than *...(left) */
let parseTree = b1 *| b2 *| (y **| (x **| z));
let minParens = b1 *| b2 *| (y **| (x **| z));
let formatted = b1 *| b2 *| (y **| (x **| z));
/* **...(right) is higher than *...(left) */
let parseTree =
b1 *| b2 *| (y **| (x **| z *| a));
let minParens =
b1 *| b2 *| (y **| (x **| z *| a));
let formatted =
b1 *| b2 *| (y **| (x **| z *| a));
/* |...(left) is higher than ||(right) */
/* All parens should be removed when formatting n > 0 times */
let parseTree = b1 || b2 || y |* x |* z;
let minParens = b1 || b2 || y |* x |* z;
let formatted = b1 || b2 || y |* x |* z;
/* Associativity effects how parenthesis should be dropped */
/* This one *shouldn't* expand into two consecutive infix + */
first + (second + third);
/* This one *should* */
first + second + third;
/* But that's just because + is left associative. Since & is right associative,
* it's the opposite. */
/* This one *should* expand into two consecutive infix * */
first & second & third;
/* This one *shouldn't* */
(first & second) & third;
/* || is basically the same as &/&& */
first || second || third;
/* This one *shouldn't* */
(first || second) || third;
/* No parens should be added/removed from the following when formatting */
let seeWhichCharacterHasHigherPrecedence =
(first |> second |> third) ^> fourth;
let seeWhichCharacterHasHigherPrecedence =
first |> second |> third;
let seeWhichCharacterHasHigherPrecedence =
first + second + third;
let comparison = (==);
/* Why would the following two cases have different grouping? */
let res =
blah
|| DataConstructor(10)
|| DataConstructor(10)
&& 10;
let res =
blah
&& DataConstructor(10)
&& DataConstructor(10)
+ 10;
/* This demonstrates how broken infix pretty printing is:
*/
let curriedComparison = (==)(10);
let resultOfAdd = 10 + 20 + 40;
let resultOfAddAndMult =
10 * 1 + 20 * 1 + 40 * 1;
let greaterThanAndSubtract = 1 - 2 > 4 + 3;
let greaterThanAndFunctionCalls =
pred(1) > pred(2);
let lessThanAndFunctionCalls =
pred(1) < pred(2);
/* This doesn't type check because it looks like pred - 1 */
let minusAndInteger = pred - 1;
let passingMinusOneToFunction = pred(-1);
let leadingMinusIsCorrectlyNeg = (-1) + 20;
let leadingMinusIsCorrectlyNeg = 3 > (-1);
/* Custom infix without labeled args */
let (|>) = (first, second) => first + second;
/* Should reformat to actually be placed infix */
let res = first |> second;
/* Curried shouldn't place infix */
let res = (|>)(first);
/* Custom infix with labeled args */
let (|>) = (~first, ~second) => first + second;
/* Should NOT reformat named args to actually be placed infix */
let res = (|>)(~first, ~second);
/* Curried shouldn't place infix */
let res = (|>)(~first);
/* Custom infix accepting *three* without labeled args */
let (|>) = (firsfirst, second, third) =>
first + second + third;
/* Should reformat to actually be placed infix if passed two args */
let res = first |> second;
let res = (first |> second)(third);
/* Should NOT reformat to be placed infix if passed all three */
let res = (|>)(first, second, third);
/* Same: Curried shouldn't place infix */
let res = (|>)(first);
/* In fact, if even just one of the arguments are named, it shouldn't
* be formatted or parsed as infix! */
(|>)(first, ~second);
(|>)(~first, second);
(|>)(first, second, ~third);
(first |> second)(~third);
/* Infix has lower precedence than function application */
first |> second(~third);
let leftAssocGrouping = first |> second |> third;
let rightAssocGrouping =
first ^> second ^> third;
/* It's definitely the caret. */
let seeWhichCharacterHasHigherPrecedence =
first |> second ^> third;
let seeWhichCharacterHasHigherPrecedence =
first ^> second |> third;
let seeWhichCharacterHasHigherPrecedence =
first ^> (second |> third) |> fourth;
let res =
blah
&& DataConstructor(10)
&& DataConstructor(10)
+ 10;
/* Should be parsed as */
let res =
blah
&& DataConstructor(10)
&& DataConstructor(10)
+ 10;
let (++) = (~label, ~label2) => label + label2;
let (++) = (~label, ~label2) => label + label2;
let (++) = (++);
let (++): int = int = (++);
(++)(~label=20, ~label2=30) + 40;
/* Should be parsed as: */
(++)(~label=20, ~label2=30) + 40;
/* Great idea! */
let (==) = (a, b) => a < 0;
let (==) = (a, b) => a < 0;
let (==) = (==);
let (==): int = int = (==);
let equal = Pervasives.(==);
let starInfix_makeSureSpacesSurround = ( * );
let starInfix_makeSureSpacesSurround = ( *** );
/* The following two should be equivalently parsed/printed. */
let includesACommentCloseInIdentifier = ( **\/ );
let includesACommentCloseInIdentifier = ( **\/ );
let shouldSimplifyAnythingExceptApplicationAndConstruction =
call("hi")
++ (
switch (x) {
| _ => "hi"
}
)
++ "yo";
let shouldRemoveParens = ident + ident + ident;
let shouldRemoveParens = ident ++ ident ++ ident;
let shouldPreserveParens =
ident + (ident + ident);
let shouldPreserveParens =
(ident ++ ident) ++ ident;
/**
* Since ++ is now INFIXOP1, it should have lower priority than INFIXOP2 (which
* includes the single plus sign). That means no parens are required in the
* following scenario even though they'd be required in (ident ++ ident) ++ ident.
*/
let noParensRequired = ident + ident ++ ident;
/* So in this case, it should format to whatever the previous example formats to. */
let noParensRequired = ident + ident ++ ident;
/**
* Everything that was said above should be true of minus sign as well. In
* terms of precedence, plus sign should be treated the same as plus sign
* followed by a dollar sign. And +++ should be treated the same as ++.
* should also be true of plus sign followed by dollar sign for example.
*/
let shouldRemoveParens = ident - ident - ident;
let shouldPreserveParens =
ident - (ident - ident);
let shouldPreserveParens =
ident +$ (ident +$ ident);
let noParensRequired = ident - ident ++ ident;
let noParensRequired = ident - ident ++ ident;
let noParensRequired = ident +$ ident ++ ident;
let noParensRequired = ident + ident +++ ident;
let noParensRequired = ident + ident +++ ident;
/* Parens are required any time you want to make ++ or +++ parse with higher
* priority than + or - */
let parensRequired = ident + (ident ++ ident);
let parensRequired = ident + (ident +++ ident);
let parensRequired = ident + (ident ++- ident);
let parensRequired = ident +$ (ident ++- ident);
/* ++ and +++ have the same parsing precedence, so it's right associative.
* Parens are required if you want to group to the left, even when the tokens
* are different.*/
let parensRequired = (ident ++ ident) +++ ident;
let parensRequired = (ident +++ ident) ++ ident;
/* Add tests with IF/then mixed with infix/constructor application on left and right sides */
/**
* Every star or forward slash after the character of an infix operator must be
* escaped.
*/
let ( /\* ) = (a, b) => a + b;
let x = 12 /-* 23 /-* 12;
let y = a /\* b;
let ( !=* ) = (q, r) => q + r;
let res = q(( !=* ), r);
let ( !=/\* ) = (q, r) => q + r;
let res = q(( !=/\* ), r);
let ( ~* ) = a => a + 1;
let res = ~*10;
let res = f - (- x);
let res = f - (- x);
let res = - (- x);
let res = f(- x);
/**
* Test using almost simple prefix as regular function.
*/
let (!!) = (a, b) => a + b;
let res = (!!)(20, 40);
/* The semicolon should be attached to someType */
let myFunc =
(
aaaa,
bbbb,
cccc,
dddd,
aaaa,
bbbb,
cccc,
dddd,
aaaa,
) => [
blah(
aaaa,
bbbb,
cccc,
dddd,
aaaa,
bbbb,
cccc,
dddd,
aaaa,
),
...someType,
];
/**
* Testing various fixity.
*/
/**
* For each of these test cases for imperative updates, we'll test both record
* update, object member update and array update.
*/
let containingObject = {
val mutable y = 0;
val arr = [|true, false, false|];
val bigArr = "goodThingThisIsntTypeChecked";
val str = "string";
pub testCases = () => {
/**
* The lowest precedence token is =, followed by :=, and then ?, then :.
*
* The following text
*
* x.contents = tenaryTest ? ifTrue : ifFalse
*
* Generates the following parse tree:
*
* =
* / \
* / \
* record ternary
*
* Because when encountering the ? the parser will shift on the ? instead of
* reducing expr = expr
*/
/**
* Without a + 1
*/
(x.contents = something ? hello : goodbye);
y = something ? hello : goodbye;
arr[0] = something ? hello : goodbye;
bigArr.{0} = something ? hello : goodbye;
str.[0] = something ? hello : goodbye;
(x.contents = something) ? hello : goodbye;
(y = something) ? hello : goodbye;
(arr[0] = something) ? hello : goodbye;
(bigArr.{0} = something) ? hello : goodbye;
(str.[0] = something) ? hello : goodbye;
x.contents = something ? hello : goodbye;
y = something ? hello : goodbye;
arr[0] = something ? hello : goodbye;
bigArr.{0} = something ? hello : goodbye;
str.[0] = something ? hello : goodbye;
/**
* With a + 1
*/
(
x.contents = something + 1 ? hello : goodbye
);
x := something + 1 ? hello : goodbye;
y = something + 1 ? hello : goodbye;
arr[0] = something + 1 ? hello : goodbye;
bigArr.{0} = something + 1 ? hello : goodbye;
str.[0] = something + 1 ? hello : goodbye;
(x.contents = something + 1)
? hello : goodbye;
(x := something + 1) ? hello : goodbye;
(y = something + 1) ? hello : goodbye;
(arr[0] = something + 1) ? hello : goodbye;
(bigArr.{0} = something + 1)
? hello : goodbye;
(str.[0] = something + 1) ? hello : goodbye;
x.contents = something + 1 ? hello : goodbye;
x := something + 1 ? hello : goodbye;
y = something + 1 ? hello : goodbye;
arr[0] = something + 1 ? hello : goodbye;
bigArr.{0} = something + 1 ? hello : goodbye;
str.[0] = something + 1 ? hello : goodbye;
/**
* #NotActuallyAConflict
* Note that there's a difference with how = and := behave.
* We only *simulate* = being an infix identifier for the sake of printing,
* but for parsing it's a little more nuanced. There *isn't* technically a
* shift/reduce conflict in the following that must be resolved via
* precedence ranking:
*
* a + b.c = d
*
* No conflict between reducing a + b.c, and shifting =, like there would
* be if it was := instead of =. That's because the rule for = isn't the
* infix rule with an arbitrary expression on its left - it's something
* much more specific.
*
* (simple_expr) DOT LIDENT EQUAL expression.
*
* So with the way yacc/menhir works, when it sees an equal sign, it knows
* that there is no valid parse where a + b.c is reduced to an expression
* with an = immediately appearing after, so it shifts the equals.
*
* If you replace = with :=, you'd see different behavior.
*
* a + b.c := d
*
* Since := has lower precedence than +, it would be parsed as:
*
* (a + b.c) := d
*
* However, our printing logic will print = assignment with parenthesis:
*
* a + (b.c = d)
*
* Even though they're not needed, because it doesn't know details about
* which rules are valid, we just told it to print = as if it were a valid
* infix identifier.
*
* Another case:
*
* something >>= fun x => x + 1;
*
* Will be printed as:
*
* something >>= (fun x => x + 1);
*
* Because the arrow has lower precedence than >>=, but it wasn't needed because
*
* (something >>= fun x) => x + 1;
*
* Is not a valid parse. Parens around the `=>` weren't needed to prevent
* reducing instead of shifting. To optimize this part, we need a much
* deeper encoding of the parse rules to print parens only when needed.
*
*/
/* The following */
x
+ (something.contents = y);
x + (something = y);
x + something.contents := y;
x + something := y;
/* Should be parsed as: */
x + (something.contents = y); /* Because of the #NotActuallyAConflict above */
x + (something = y); /* Same */
x + something.contents := y;
x + something := y;
/* To make the := parse differently, we must use parens */
x + (something.contents := y);
x + (something := y);
/**
* Try with ||
*/
x.contents
|| something
+ 1
? hello : goodbye;
y || something + 1 ? hello : goodbye;
arr[0] || something + 1 ? hello : goodbye;
bigArr.{0} || something + 1
? hello : goodbye;
str.[0] || something + 1 ? hello : goodbye;
x.contents || something + 1
? hello : goodbye;
y || something + 1 ? hello : goodbye;
arr[0] || something + 1 ? hello : goodbye;
bigArr.{0} || something + 1
? hello : goodbye;
str.[0] || something + 1 ? hello : goodbye;
x.contents
|| (something + 1 ? hello : goodbye);
y || (something + 1 ? hello : goodbye);
arr[0] || (something + 1 ? hello : goodbye);
bigArr.{0}
|| (something + 1 ? hello : goodbye);
str.[0] || (something + 1 ? hello : goodbye);
/**
* Try with &&
*/
x.contents
&& something
+ 1
? hello : goodbye;
y && something + 1 ? hello : goodbye;
arr[0] && something + 1 ? hello : goodbye;
bigArr.{0} && something + 1
? hello : goodbye;
str.[0] && something + 1 ? hello : goodbye;
x.contents && something + 1
? hello : goodbye;
y && something + 1 ? hello : goodbye;
arr[0] && something + 1 ? hello : goodbye;
bigArr.{0} && something + 1
? hello : goodbye;
str.[0] && something + 1 ? hello : goodbye;
x.contents
&& (something + 1 ? hello : goodbye);
y && (something + 1 ? hello : goodbye);
arr[0] && (something + 1 ? hello : goodbye);
bigArr.{0}
&& (something + 1 ? hello : goodbye);
str.[0] && (something + 1 ? hello : goodbye);
/**
* See how regular infix operators work correctly.
*/
(x.contents = 2 + 4);
y = 2 + 4;
arr[0] = 2 + 4;
bigArr.{0} = 2 + 4;
str.[0] = 2 + 4;
(x.contents = 2) + 4;
(y = 2) + 4;
(arr[0] = 2) + 4;
(bigArr.{0} = 2) + 4;
(str.[0] = 2) + 4;
/**
* Ensures that record update, object field update, and := are all right
* associative.
*/
(x.contents = y.contents = 10);
y = x.contents = 10;
arr[0] = x.contents = 10;
bigArr.{0} = x.contents = 10;
str.[0] = x.contents = 10;
/* Should be the same as */
x.contents = x.contents = 10;
y = x.contents = 10;
arr[0] = x.contents = 10;
bigArr.{0} = x.contents = 10;
str.[0] = x.contents = 10;
/**
* Ensures that record update, object field update, and := are all right
* associative.
*/
x :=
x := 10;
/* Should be the same as */
x := x := 10;
/* By default, without parens*/
x ? y : z ? a : b;
/* It is parsed as the following: */
x ? y : z ? a : b;
/* Not this: */
(x ? y : z) ? a : b;
/**
* ^
* When rendering the content to the left of the ? we know that we want the
* parser to reduce the thing to the left of the ? when the ? is seen. So we
* look at the expression to the left of ? and discover what precedence level
* it is (token of its rightmost terminal). We then compare it with ? to see
* who would win a shift reduce conflict. We want the term to the left of the ?
* to be reduced. So if it's rightmost terminal isn't higher precedence than ?,
* we wrap it in parens.
*/
(
/***
* The following
*/
x.contents =
something
? x.contents = somethingElse : goodbye
);
y = something ? y = somethingElse : goodbye;
arr[0] =
something
? arr[0] = somethingElse : goodbye;
bigArr.{0} =
something
? bigArr.{0} = somethingElse : goodbye;
str.[0] =
something
? str.[0] = somethingElse : goodbye;
/*
* Should be parsed as
*/
x.contents =
something
? x.contents = somethingElse : goodbye;
y = something ? y = somethingElse : goodbye;
arr[0] =
something
? arr[0] = somethingElse : goodbye;
bigArr.{0} =
something
? bigArr.{0} = somethingElse : goodbye;
str.[0] =
something
? str.[0] = somethingElse : goodbye;
/** And this */
y :=
something ? y := somethingElse : goodbye;
arr[0] :=
something
? arr[0] := somethingElse : goodbye;
bigArr.{0} :=
something
? bigArr.{0} := somethingElse : goodbye;
str.[0] :=
something
? str.[0] := somethingElse : goodbye;
/* Should be parsed as */
y := something ? y := somethingElse : goodbye;
arr[0] :=
something
? arr[0] := somethingElse : goodbye;
bigArr.{0} :=
something
? bigArr.{0} := somethingElse : goodbye;
str.[0] :=
something
? str.[0] := somethingElse : goodbye;
/* The following */
x :=
something
? x.contents =
somethingElse ? goodbye : goodbye
: goodbye;
x :=
something
? arr[0] =
somethingElse ? goodbye : goodbye
: goodbye;
x :=
something
? bigArr.{0} =
somethingElse ? goodbye : goodbye
: goodbye;
x :=
something
? str.[0] =
somethingElse ? goodbye : goodbye
: goodbye;
/* Is parsed as */
x :=
something
? x.contents =
somethingElse ? goodbye : goodbye
: goodbye;
x :=
something
? arr[0] =
somethingElse ? goodbye : goodbye
: goodbye;
x :=
something
? bigArr.{0} =
somethingElse ? goodbye : goodbye
: goodbye;
x :=
something
? str.[0] =
somethingElse ? goodbye : goodbye
: goodbye;
/* is not the same as */
x :=
something
? (x.contents = somethingElse)
? goodbye : goodbye
: goodbye;
x :=
something
? (arr[0] = somethingElse)
? goodbye : goodbye
: goodbye;
x :=
something
? (bigArr.{0} = somethingElse)
? goodbye : goodbye
: goodbye;
x :=
something
? (str.[0] = somethingElse)
? goodbye : goodbye
: goodbye;
/**
* And
*/
/** These should be parsed the same */
something
? somethingElse
: x.contents = somethingElse ? x : z;
something
? somethingElse
: x.contents = somethingElse ? x : z;
/* Not: */
something
? somethingElse
: (x.contents = somethingElse) ? x : z;
(
something
? somethingElse
: x.contents = somethingElse
)
? x : z;
/* These should be parsed the same */
something
? somethingElse
: x := somethingElse ? x : z;
something
? somethingElse
: x := somethingElse ? x : z;
/* Not: */
something
? somethingElse
: (x := somethingElse) ? x : z;
(
something
? somethingElse : x := somethingElse
)
? x : z;
/** These should be parsed the same */
something
? somethingElse : y = somethingElse ? x : z;
something
? somethingElse : y = somethingElse ? x : z;
/* Not: */
something
? somethingElse
: (y = somethingElse) ? x : z;
(
something
? somethingElse : y = somethingElse
)
? x : z;
/** These should be parsed the same */
something
? somethingElse
: arr[0] = somethingElse ? x : arr[0];
something
? somethingElse
: arr[0] = somethingElse ? x : arr[0];
/* Not: */
something
? somethingElse
: (arr[0] = somethingElse) ? x : z;
(
something
? somethingElse : arr[0] = somethingElse
)
? x : z;
/** These should be parsed the same */
something
? somethingElse
: bigArr.{0} =
somethingElse ? x : bigArr.{0};
something
? somethingElse
: bigArr.{0} =
somethingElse ? x : bigArr.{0};
/* Not: */
something
? somethingElse
: (bigArr.{0} = somethingElse) ? x : z;
(
something
? somethingElse
: bigArr.{0} = somethingElse
)
? x : z;
/** These should be parsed the same */
something
? somethingElse
: arr.[0] = somethingElse ? x : arr.[0];
something
? somethingElse
: arr.[0] = somethingElse ? x : arr.[0];
/* Not: */
something
? somethingElse
: (str.[0] = somethingElse) ? x : z;
(
something
? somethingElse : str.[0] = somethingElse
)
? x : z;
/**
* It creates a totally different meaning when parens group the :
*/
(
x.contents =
something
? (x.contents = somethingElse: x) : z
);
y = something ? (y = somethingElse: x) : z;
arr[0] =
something
? (arr[0] = somethingElse: x) : z;
bigArr.{0} =
something
? (bigArr.{0} = somethingElse: x) : z;
str.[0] =
something
? (str.[0] = somethingElse: x) : z;
/**
* Various precedence groupings.
*/
true
? true ? false : false : false;
/* Is the same as */
true ? true ? false : false : false;
/*
* Just some examples of how prefix will be printed.
*/
- x + (something.contents = y);
- x + (something = y);
- x + something.contents := y;
- x + something := y;
x + (- (something.contents = y));
x + (- (something = y));
x + (- something.contents) := y;
x + (- something) := y;
x.contents || something + 1
? - hello : goodbye;
bigArr.{0} || - something + 1
? hello : goodbye;
let result = - x + (something.contents = y);
/* Prefix minus is actually sugar for regular function identifier ~-*/
let result = 2 + (- add(4, 0));
/* Same as */
let result = 2 + (- add(4, 0));
/* Same as */
let result = 2 + (- add(4, 0));
/* That same example but with ppx attributes on the add application */
let result = 2 + (- [@ppx] add(4, 0));
/* Same as */
let result = [@ppx] 2 + (- add(4, 0));
/* Same as */
let result = [@ppx] 2 + (- add(4, 0));
/* Multiple nested prefixes */
let result = 2 + (- (- (- add(4, 0))));
/* And with attributes */
let result =
[@onAddApplication] 2
+ (- (- (- add(4, 0))));
/**
* TODO: Move all of these test cases to attributes.re.
*/
/* Attribute on the prefix application */
let res = [@attr] (- something(blah, blah));
/* Attribute on the regular function application, not prefix */
let res = [@attr] (- something(blah, blah));
let attrOnPrefix = [@ppxOnPrefixApp] (-1);
let attrOnPrefix = 5 + (-1);
let result =
[@ppxAttributeOnSugarGetter] arr.[0];
/**
* Unary plus/minus has lower precedence than prefix operators:
* And unary plus has same precedence as unary minus.
*/
let res = - (!record);
/* Should be parsed as: */
let res = - (!record);
/* Although that precedence ranking doesn't likely have any effect in that
* case. */
/**
* And this
*/
let res = - (+ callThisFunc());
/* should be parsed as: */
let res = - (+ callThisFunc());
/**
* And this
*/
let res = !(- callThisFunc());
/* Should be parsed (and should remain printed as: */
let res = !(- callThisFunc());
let res = [@onApplication] (!x);
let res = ![@onX] x;
let res = ![@onX] x;
[@shouldBeRenderedOnEntireSetField]
(something.contents = "newvalue");
something.contents =
[@shouldBeRenderedOnString] "newvalue";
}
};
let x = foo |> z;
let x = foo |> f |> g;
let x =
foo
|> somelongfunctionname("foo")
|> anotherlongfunctionname("bar", 1)
|> somelongfunction
|> bazasdasdad;
let code =
JSCodegen.Code.(
create
|> lines(
Requires.(
create
|> import_type(
~local="Set",
~source="Set",
)
|> import_type(
~local="Map",
~source="Map",
)
|> import_type(
~local="Immutable",
~source="immutable",
)
|> require(
~local="invariant",
~source="invariant",
)
|> require(
~local="Image",
~source="Image.react",
)
|> side_effect(
~source="monkey_patches",
)
|> render_lines
),
)
|> new_line
|> new_line
|> new_line
|> new_line
|> render
);
let code = JSCodegen.Code.(create |> render);
let server = {
let callback = (_conn, req, body) => {
let uri =
req
|> Request.uri
|> Uri.to_string
|> Code.string_of_uri
|> Server.respond
|> Request.uri;
let meth =
req
|> Request.meth
|> Code.string_of_method;
let headers =
req |> Request.headers |> Header.to_string;
body
|> Cohttp_lwt_body.to_string
>|= (
body => {
Printf.sprintf(
"okokok",
uri,
meth,
headers,
body,
);
}
)
>>= (
body =>
Server.respond_string(
~status,
~body,
(),
)
);
};
Server.create(
~mode,
Server.make(~callback, ()),
);
};
let lijst =
List.length @@
List.map(
s => s ++ " example",
[
"one",
"two",
"three",
"four",
"five",
"six",
"seven",
"eight",
"nine",
"ten",
],
);
let example =
true != false
&& "a" == "b"
&& "arbitrary" === "example"
&& "how long" >= "can you get"
&& "seriously" <= "what is the line length";
if (List.length(files) > 0
&& List.length(otherfiles) < 2) {
();
};
/* Don't clash with jsx edge cases */
let (=<) = (a, b) => a + b;
let result = x =< y;
let z = x =< y;
let z = x =< y;
let (></) = (a, b) => a - b;
let result = x ></ b;
let z = x ></ b;
let z = x ></ b;
let (=</>) = (a, b) => a + b;
let result = x =</> b;
let z = x =</> b;
let z = x =</> b;
/* #1676: Exponentiation should be right-associative */
let foo =
(100. /. 2.) ** 2. +. (200. /. 2.) ** 2.;
let foo = 100. /. 2. ** 2. +. 200. /. 2. ** 2.;
let x = y />> f;
let (/>>) = (a, b) => a + b;
let x = y />/> f;
let (/>/>) = (a, b) => a + b;
let (><) = (a, b) => a + b;
let x = a >< b;
let (=-) = (a, b) => a + b;
let foo = (a, b) => a =- b;
let (=><) = (a, b) => a + b;
let x = a =>< b;
let foo =
fun
| None => x >>= y
| Some(x) => x >>= y;
something
>>= (
fun
| None => x >>= y
| Some(x) => x >>= y
);
(
fun
| None => x >>= y
| Some(x) => x >>= y
)
>>= bar;
something
>>= (
fun
| None => x >>= y
| Some(x) => x >>= y
);
something
? a
>>= (
fun
| None => x >>= y
| Some(x) => x >>= y
)
: fun
| None => x >>= y
| Some(x) => x >>= y;
something
? a
>>= (
fun
| None => x >>= y
| Some(x) => x >>= y
)
: (
fun
| None => x >>= y
| Some(x) => x >>= y
)
>>= b;
let foo =
fun
| None => ()
| Some(x) => (
fun
| None => ()
| Some(_) => ()
);
let foo =
fun
| Some(x) => (
fun
| None => ()
| Some(_) => ()
)
| None => ();
let predicate =
predicate === Functions.alwaysTrue1
? (
fun
| None => false
| Some(exn) => predicate(exn)
)
>>= foo
: fun
| None => false
| Some(exn) => predicate(exn);
let predicate =
predicate === Functions.alwaysTrue1
? (
fun
| None => false
| Some(exn) => predicate(exn)
)
>>= foo
: bar
>>= (
fun
| None => false
| Some(exn) => predicate(exn)
);
let (>...) = (a, b) => a + b;
a >... b;
/* https://github.com/facebook/reason/issues/2169 */
let not = x => !x;
let other = x => not(x);
let derefInsideArray = [|a^|];
/* https://github.com/facebook/reason/issues/126 */
foo^ ^;
let x = foo^ ^;
foo ^^ bar;
/* So in this case, it should format to whatever the previous example formats to. */
/* Add tests with IF/then mixed with infix/constructor application on left and right sides */
================================================
FILE: test/inlineRecord.t/input.re
================================================
type t0 = T0 { t0 : int };
type t1 =
| A { x : int }
| B
| C { c1 : string, c2 : string };
/* GADT */
type t2(_) =
| D { x : int } : t2(int)
| E { f : int => int } : t2(int => int)
| F(unit) : t2(unit);
================================================
FILE: test/inlineRecord.t/run.t
================================================
See the typed tree from ./input.re
$ cat ./input.re | ../lib/outcometreePrinter.exe
type t0 = T0({ t0: int, });
type t1 = A({ x: int, }) | B | C({ c1: string, c2: string, });
type t2(_) =
D({ x: int, }): t2(int)
| E({ f: int => int, }): t2(int => int)
| F(unit): t2(unit);
================================================
FILE: test/jsx.t/input.re
================================================
let x =
<Window
style={
"width": state.width,
"height": 400,
"paddingTop": 100,
"paddingBottom": 100,
"paddingLeft": 100,
"paddingRight": 100,
"justifyContent": CssJustifySpaceBetween,
"flexDirection": CssFlexDirectionRow
}
onKey=updater(handleInput)
/>;
let y =
<Routes
path=Routes.stateToPath(state)
isHistorical=true
onHashChange=((_oldPath,_oldUrl,newUrl) =>
updater((latestComponentBag,_) => {
let currentActualPath = Routes.hashOfUri(newUrl);
let pathFromState = Routes.stateToPath(latestComponentBag.state);
currentActualPath == pathFromState ?
None : dispatchEventless(State.UriNavigated(currentActualPath),latestComponentBag,())
},
()
)
)
/>;
let z =
<div
style=ReactDOMRe.Style.make(
~width,
~height,
~color,
~backgroundColor,
~margin,
~padding,
~border,
~borderColor,
~someOtherAttribute,
())
key=string_of_int(1)
/>;
let omega =
<div
aList=[
width,
height,
color,
backgroundColor,
margin,
padding,
border,
borderColor,
someOtherAttribute
]
key=string_of_int(1)
/>;
let someArray = <div
anArray=[|width, height, color, backgroundColor, margin, padding, border,borderColor,someOtherAttribute|] key=string_of_int(1) />;
let tuples =
<div
aTuple=(width,
height,
color,
backgroundColor,
margin,
padding,
border,
borderColor,
someOtherAttribute,
definitelyBreakere)
key=string_of_int(1)
/>;
let icon = <Icon
name=(switch (state.volume) {
| v when v < 0.1 => "sound-off"
| v when v < 0.11 => "sound-min"
| v when v < 0.51 => "sound-med"
| _ => "sound-max"
}
)
/>;
<MessengerSharedPhotosAlbumViewPhotoReact
ref=?(
foo##bar === baz ?
Some(foooooooooooooooooooooooo(setRefChild)) : None
)
key=node##legacy_attachment_id
/>;
/* punning */
<Foo bar />;
/* punning for explicitly passed optional */
<Foo bar=?bar />;
/* Don't pun for explicitly props with attributes */
<Foo bar=?{[@browser_only]bar} />;
/* don't pun explicitly passed optional with module identifier */
<Foo bar=?Baz.bar />;
let x = <div />;
<div asd=1></div>;
foo#=(<bar />);
foo#=<bar />;
let x =[|<div />|];
let x = [|<Button onClick=handleStaleClick />, <Button onClick=handleStaleClick />|];
let z = (<div />);
let z = (<Button onClick=handleStaleClick />, <Button onClick=handleStaleClick />);
let y = [<div />, <div />];
let y = [<Button onClick=handleStaleClick />, <Button onClick=handleStaleClick />];
<Description term={<Text text="Age" />}> child </Description>;
<Description term=(Text.createElement(~text="Age", ~children=[], ()))> child </Description>;
<Description term=([@JSX] Text.createElement(~text="Age", ()))> child </Description>;
<Description term={<Text superLongPunnedProp anotherSuperLongOneCrazyLongThingHere text="Age" />}> child </Description>;
<Description term={<Text noPunnedProp={[@attribute] noPunnedProp} superLongPunnedProp anotherSuperLongOneCrazyLongThingHere text="Age" />}> child </Description>;
<Description term={<Text noPunned={[@attribute] noPunnedProp} />}> child </Description>;
<Foo bar={<Baz superLongPunnedProp anotherSuperLongOneCrazyLongThingHere/>}/>;
<div><span>(str("hello"))</span></div>;
<description term={<text text="Age" />}>child</description>;
<description term=(text(~text="Age",~children=[], ()))>child</description>;
<description term=([@JSX] text(~text="Age",~children=[]))>child</description>;
<description term=([@JSX] text(~text="Age", ()))>child</description>;
<description term={<div superLongPunnedProp anotherSuperLongOneCrazyLongThingHere text="Age" />}> child </description>;
Module.[<Component><div test="asd" /></Component>];
Module.[<Component><div/></Component>];
Module.[<Foo><Bar/></Foo>];
Module.[<Component />];
let (/></) = (a, b) => a + b;
let x = foo /></ bar;
/* https://github.com/facebook/reason/issues/870 */
<div onClick=this##handleClick>
<>foo</>
</div>;
<div onClick=this##handleClick>
<>(foo(bar))</>
</div>;
/* function application */
<div onClick=this##handleClick>
<>{foo(bar)}</>
</div>;
/* tuple, not function application */
<div onClick=this##handleClick>
<> foo(bar) </>
</div>;
/* https://github.com/facebook/reason/issues/2020 */
<div></div >;
<div>foo</ div>;
<div> </ div >;
<Component
accept=(
fun
| Foo => true
| Bar => false
)
/>;
<C
prop=M.{
a: "xxxxxxxxxxxxxxxxxxxxxx",
b: "xxxxxxxxxxxxxxxxxxxxxx",
c: "xxxxxxxxxxxxxxxxxxxxxx",
}
/>;
<C
prop=M.[
"xxxxxxxxxxxxxxxxxxxxxx",
"xxxxxxxxxxxxxxxxxxxxxx",
"xxxxxxxxxxxxxxxxxxxxxx",
]
/>;
<C
prop=M.[|
"xxxxxxxxxxxxxxxxxxxxxx",
"xxxxxxxxxxxxxxxxxxxxxx",
"xxxxxxxxxxxxxxxxxxxxxx",
|]
/>;
<C
prop=M.(
"xxxxxxxxxxxxxxxxxxxxxx",
"xxxxxxxxxxxxxxxxxxxxxx",
"xxxxxxxxxxxxxxxxxxxxxx",
)
/>;
<C
prop=M.(Foo(
"xxxxxxxxxxxxxxxxxxxxxx",
"xxxxxxxxxxxxxxxxxxxxxx",
"xxxxxxxxxxxxxxxxxxxxxx",
))
/>;
/* https://github.com/facebook/reason/issues/2028 */
<Foo bar=M.[]></Foo>;
<Foo bar=M.[]> M.[] </Foo>;
<Foo bar=M.[]> ...M.[] </Foo>;
switch(foo) {
| `Variant =><Component />
};
<div>...c</div>;
<div onClick={(event) => handleChange(event)} />;
<div onClick={(eventWithLongIdent) => handleChange(eventWithLongIdent)} />;
<div
onClick={(event) => {
Js.log(event);
handleChange(event);
}}
/>;
<UncurriedDiv
onClick={(. event) => {
Js.logU(. event);
handleChange(. event);
}}
/>;
<UncurriedDiv
onClick={(. eventUncurried) =>
handleChange(. eventUncurried)
}
/>;
<StaticDiv
onClick={(foo, bar, baz, lineBreak, identifier) => {
doStuff(foo, bar, baz);
bar(lineBreak, identifier);
}}
/>;
<StaticDiv
onClick={(foo, bar, baz, lineBreak, identifier) => {
bar(lineBreak, identifier)
}}
/>;
<AttrDiv onClick={[@bar] (event) => handleChange(event)} />;
<AttrDiv onClick={[@bar] (eventLongIdentifier) => handleChange(eventLongIdentifier)} />;
<StaticDivNamed
onClick={(
~foo,
~bar,
~baz,
~lineBreak,
~identifier,
()
) =>
bar(lineBreak, identifier)
}
/>;
<div
onClick={(e): event => {
doStuff();
bar(foo);
}}
/>;
<div
onClick={(e, e2): event => {
doStuff();
bar(foo);
}}
/>;
<div
onClick={(
foo,
bar,
baz,
superLongIdent,
breakLine,
): event => {
doStuff();
bar(foo);
}}
/>;
<div
onClick={(
foo,
bar,
baz,
superLongIdent,
breakLine,
): (
event,
event2,
event3,
event4,
event5,
) => {
doStuff();
bar(foo);
}}
/>;
<div
onClick={(
foo,
bar,
baz,
superLongIdent,
breakLine,
): event =>
doStuff()
}
/>;
<div
onClick={(
foo,
bar,
baz,
superLongIdent,
breakLine,
): (
event,
event2,
event3,
event4,
event5,
) =>
doStuff()
}
/>;
<div>
{switch(color) {
| Black => ReasonReact.string("black")
| Red => ReasonReact.string("red")
}}
</div>;
ReasonReact.(<> {string("Test")} </>);
<div
style={
[@foo]
ReactDOMRe.Style.make(
~width="20px",
~height="20px",
~borderRadius="100%",
~backgroundColor="red",
)
}
/>;
<Animated initialValue=0.0 value>
...{
ReactDOMRe.Style.make(
~width="20px",
~height="20px",
~borderRadius="100%",
~backgroundColor="red",
)
}
</Animated>;
<Animated initialValue=0.0 value>
...{
value =>
<div
style={
ReactDOMRe.Style.make(
~width="20px",
~height="20px",
~borderRadius="100%",
~backgroundColor="red",
)
}
/>
}
</Animated>;
<Animated initialValue=0.0 value>
...{
(value) :ReasonReact.element =>
<div
style={
ReactDOMRe.Style.make(
~width="20px",
~height="20px",
~borderRadius="100%",
~backgroundColor="red",
)
}
/>
}
</Animated>;
<Animated initialValue=0.0 value>
...{
[@foo] value => {
<div
style={
ReactDOMRe.Style.make(
~width="20px",
~height="20px",
~borderRadius="100%",
~backgroundColor="red",
)
}
/>
}
}
</Animated>;
<Animated initialValue=0.0 value>
...{value => {
let width = "20px";
let height = "20px";
<div
style={
ReactDOMRe.Style.make(
~width,
~height,
~borderRadius="100%",
~backgroundColor="red",
)
}
/>
}
}
</Animated>;
<div callback={reduce(() => !state)} />;
<button ?id className={Cn.make(["button", "is-fullwidth"])} onClick>
{"Submit" |> ste}
</button>;
<button ?id className={Cn.make([|"button", "is-fullwidth"|])} onClick>
{"Submit" |> ste}
</button>;
<button ?id className={Cn.make(("button", "is-fullwidth"))} onClick>
{"Submit" |> ste}
</button>;
<button ?id className={Cn.make({a: b})} onClick>
{"Submit" |> ste}
</button>;
<button ?id className={Cn.make({"a": b})} onClick>
{"Submit" |> ste}
</button>;
// shouldn't result in a stack overflow
<X y={z->Belt.Option.getWithDefault("")} />;
<div style={getStyle()}> {ReasonReact.string("BugTest")} </div>;
<div>
{
let left = limit->Int.toString;
{j|$left characters left|j}->React.string;
}
</div>;
<View style=styles##backgroundImageWrapper>
{
let uri = "/images/header-background.png";
<Image
resizeMode=`contain
style=styles##backgroundImage
uri
/>
}
</View>;
<div>
{true
? {let foo = "foo"; // don't remove semi
<span> {ReasonReact.string(foo)} </span>}
: <span> {ReasonReact.string("bar")} </span>}
</div>;
let v =
<A>
<B>
...{_ => {
let renderX = x => {
let y = x ++ x;
<div key=y />;
};
renderX("foo");
}}
</B>
</A>;
<Component
prop={
x->Option.map(x => {let y = x; y ++ y})
}
/>;
<Component
prop={{
name: x->Option.map(x => {let y = x; y ++ y})
}}
/>;
<Component
prop={{
name: x ++ Option.map(x => {let y = x; y ++ y})
}}
/>;
<Component
prop={{
name: x##Option.map(x => {let y = x; y ++ y})
}}
/>;
<Component
prop={{
name: x |> Option.map(x => {let y = x; y ++ y})
}}
/>;
<A someProp={ <> {React.string("Hello")} </> } />;
<A someProp=?{ <> {React.string("Hi")} </> } />;
<ActionButton
one={!validated}
two={
msg##errorText;
}>
<InactionText three={msg##prop} four={msg##errorText} />
</ActionButton>;
<Foo.bar />;
<Foo.Bar.baz arg="hello" />;
================================================
FILE: test/jsx.t/run.t
================================================
Format JSX
$ refmt ./input.re
let x =
<Window
style={
"width": state.width,
"height": 400,
"paddingTop": 100,
"paddingBottom": 100,
"paddingLeft": 100,
"paddingRight": 100,
"justifyContent": CssJustifySpaceBetween,
"flexDirection": CssFlexDirectionRow,
}
onKey={updater(handleInput)}
/>;
let y =
<Routes
path={Routes.stateToPath(state)}
isHistorical=true
onHashChange={(_oldPath, _oldUrl, newUrl) =>
updater(
(latestComponentBag, _) => {
let currentActualPath =
Routes.hashOfUri(newUrl);
let pathFromState =
Routes.stateToPath(
latestComponentBag.state,
);
currentActualPath == pathFromState
? None
: dispatchEventless(
State.UriNavigated(
currentActualPath,
),
latestComponentBag,
(),
);
},
(),
)
}
/>;
let z =
<div
style={ReactDOMRe.Style.make(
~width,
~height,
~color,
~backgroundColor,
~margin,
~padding,
~border,
~borderColor,
~someOtherAttribute,
(),
)}
key={string_of_int(1)}
/>;
let omega =
<div
aList=[
width,
height,
color,
backgroundColor,
margin,
padding,
border,
borderColor,
someOtherAttribute,
]
key={string_of_int(1)}
/>;
let someArray =
<div
anArray=[|
width,
height,
color,
backgroundColor,
margin,
padding,
border,
borderColor,
someOtherAttribute,
|]
key={string_of_int(1)}
/>;
let tuples =
<div
aTuple=(
width,
height,
color,
backgroundColor,
margin,
padding,
border,
borderColor,
someOtherAttribute,
definitelyBreakere,
)
key={string_of_int(1)}
/>;
let icon =
<Icon
name={
switch (state.volume) {
| v when v < 0.1 => "sound-off"
| v when v < 0.11 => "sound-min"
| v when v < 0.51 => "sound-med"
| _ => "sound-max"
}
}
/>;
<MessengerSharedPhotosAlbumViewPhotoReact
ref=?{
foo##bar === baz
? Some(
foooooooooooooooooooooooo(
setRefChild,
),
)
: None
}
key=node##legacy_attachment_id
/>;
/* punning */
<Foo bar />;
/* punning for explicitly passed optional */
<Foo ?bar />;
/* Don't pun for explicitly props with attributes */
<Foo bar=?{[@browser_only] bar} />;
/* don't pun explicitly passed optional with module identifier */
<Foo bar=?Baz.bar />;
let x = <div />;
<div asd=1 />;
foo #= <bar />;
foo #= <bar />;
let x = [|<div />|];
let x = [|
<Button onClick=handleStaleClick />,
<Button onClick=handleStaleClick />,
|];
let z = <div />;
let z = (
<Button onClick=handleStaleClick />,
<Button onClick=handleStaleClick />,
);
let y = [<div />, <div />];
let y = [
<Button onClick=handleStaleClick />,
<Button onClick=handleStaleClick />,
];
<Description term={<Text text="Age" />}>
child
</Description>;
<Description
term={Text.createElement(
~text="Age",
~children=[],
(),
)}>
child
</Description>;
<Description
term={
[@JSX] Text.createElement(~text="Age", ())
}>
child
</Description>;
<Description
term={
<Text
superLongPunnedProp
anotherSuperLongOneCrazyLongThingHere
text="Age"
/>
}>
child
</Description>;
<Description
term={
<Text
noPunnedProp={[@attribute] noPunnedProp}
superLongPunnedProp
anotherSuperLongOneCrazyLongThingHere
text="Age"
/>
}>
child
</Description>;
<Description
term={
<Text noPunned={[@attribute] noPunnedProp} />
}>
child
</Description>;
<Foo
bar={
<Baz
superLongPunnedProp
anotherSuperLongOneCrazyLongThingHere
/>
}
/>;
<div> <span> {str("hello")} </span> </div>;
<description term={<text text="Age" />}>
child
</description>;
<description
term={text(~text="Age", ~children=[], ())}>
child
</description>;
<description
term={[@JSX] text(~text="Age", ~children=[])}>
child
</description>;
<description
term={[@JSX] text(~text="Age", ())}>
child
</description>;
<description
term={
<div
superLongPunnedProp
anotherSuperLongOneCrazyLongThingHere
text="Age"
/>
}>
child
</description>;
Module.[
<Component> <div test="asd" /> </Component>,
];
Module.[<Component> <div /> </Component>];
Module.[<Foo> <Bar /> </Foo>];
Module.[<Component />];
let (/></) = (a, b) => a + b;
let x = foo /></ bar;
/* https://github.com/facebook/reason/issues/870 */
<div onClick=this##handleClick>
<> foo </>
</div>;
<div onClick=this##handleClick>
<> {foo(bar)} </>
</div>;
/* function application */
<div onClick=this##handleClick>
<> {foo(bar)} </>
</div>;
/* tuple, not function application */
<div onClick=this##handleClick>
<> foo bar </>
</div>;
/* https://github.com/facebook/reason/issues/2020 */
<div />;
<div> foo </div>;
<div />;
<Component
accept={
fun
| Foo => true
| Bar => false
}
/>;
<C
prop=M.{
a: "xxxxxxxxxxxxxxxxxxxxxx",
b: "xxxxxxxxxxxxxxxxxxxxxx",
c: "xxxxxxxxxxxxxxxxxxxxxx",
}
/>;
<C
prop=M.[
"xxxxxxxxxxxxxxxxxxxxxx",
"xxxxxxxxxxxxxxxxxxxxxx",
"xxxxxxxxxxxxxxxxxxxxxx",
]
/>;
<C
prop=M.(
[|
"xxxxxxxxxxxxxxxxxxxxxx",
"xxxxxxxxxxxxxxxxxxxxxx",
"xxxxxxxxxxxxxxxxxxxxxx",
|]
)
/>;
<C
prop=M.(
"xxxxxxxxxxxxxxxxxxxxxx",
"xxxxxxxxxxxxxxxxxxxxxx",
"xxxxxxxxxxxxxxxxxxxxxx",
)
/>;
<C
prop=M.(
Foo(
"xxxxxxxxxxxxxxxxxxxxxx",
"xxxxxxxxxxxxxxxxxxxxxx",
"xxxxxxxxxxxxxxxxxxxxxx",
)
)
/>;
/* https://github.com/facebook/reason/issues/2028 */
<Foo bar=M.[] />;
<Foo bar=M.[]> M.[] </Foo>;
<Foo bar=M.[]> ...M.[] </Foo>;
switch (foo) {
| `Variant => <Component />
};
<div> ...c </div>;
<div onClick={event => handleChange(event)} />;
<div
onClick={eventWithLongIdent =>
handleChange(eventWithLongIdent)
}
/>;
<div
onClick={event => {
Js.log(event);
handleChange(event);
}}
/>;
<UncurriedDiv
onClick={(. event) => {
Js.logU(. event);
handleChange(. event);
}}
/>;
<UncurriedDiv
onClick={(. eventUncurried) =>
handleChange(. eventUncurried)
}
/>;
<StaticDiv
onClick={(
foo,
bar,
baz,
lineBreak,
identifier,
) => {
doStuff(foo, bar, baz);
bar(lineBreak, identifier);
}}
/>;
<StaticDiv
onClick={(
foo,
bar,
baz,
lineBreak,
identifier,
) => {
bar(lineBreak, identifier)
}}
/>;
<AttrDiv
onClick={[@bar] event => handleChange(event)}
/>;
<AttrDiv
onClick={[@bar] eventLongIdentifier =>
handleChange(eventLongIdentifier)
}
/>;
<StaticDivNamed
onClick={(
~foo,
~bar,
~baz,
~lineBreak,
~identifier,
(),
) =>
bar(lineBreak, identifier)
}
/>;
<div
onClick={(e): event => {
doStuff();
bar(foo);
}}
/>;
<div
onClick={(e, e2): event => {
doStuff();
bar(foo);
}}
/>;
<div
onClick={(
foo,
bar,
baz,
superLongIdent,
breakLine,
): event => {
doStuff();
bar(foo);
}}
/>;
<div
onClick={(
foo,
bar,
baz,
superLongIdent,
breakLine,
): (
event,
event2,
event3,
event4,
event5,
) => {
doStuff();
bar(foo);
}}
/>;
<div
onClick={(
foo,
bar,
baz,
superLongIdent,
breakLine,
): event =>
doStuff()
}
/>;
<div
onClick={(
foo,
bar,
baz,
superLongIdent,
breakLine,
): (
event,
event2,
event3,
event4,
event5,
) =>
doStuff()
}
/>;
<div>
{switch (color) {
| Black => ReasonReact.string("black")
| Red => ReasonReact.string("red")
}}
</div>;
ReasonReact.(<> {string("Test")} </>);
<div
style={
[@foo]
ReactDOMRe.Style.make(
~width="20px",
~height="20px",
~borderRadius="100%",
~backgroundColor="red",
)
}
/>;
<Animated initialValue=0.0 value>
...{ReactDOMRe.Style.make(
~width="20px",
~height="20px",
~borderRadius="100%",
~backgroundColor="red",
)}
</Animated>;
<Animated initialValue=0.0 value>
...{value =>
<div
style={ReactDOMRe.Style.make(
~width="20px",
~height="20px",
~borderRadius="100%",
~backgroundColor="red",
)}
/>
}
</Animated>;
<Animated initialValue=0.0 value>
...{(value): ReasonReact.element =>
<div
style={ReactDOMRe.Style.make(
~width="20px",
~height="20px",
~borderRadius="100%",
~backgroundColor="red",
)}
/>
}
</Animated>;
<Animated initialValue=0.0 value>
...{[@foo] value => {
<div
style={ReactDOMRe.Style.make(
~width="20px",
~height="20px",
~borderRadius="100%",
~backgroundColor="red",
)}
/>
}}
</Animated>;
<Animated initialValue=0.0 value>
...{value => {
let width = "20px";
let height = "20px";
<div
style={ReactDOMRe.Style.make(
~width,
~height,
~borderRadius="100%",
~backgroundColor="red",
)}
/>;
}}
</Animated>;
<div callback={reduce(() => !state)} />;
<button
?id
className={Cn.make([
"button",
"is-fullwidth",
])}
onClick>
{"Submit" |> ste}
</button>;
<button
?id
className={Cn.make([|
"button",
"is-fullwidth",
|])}
onClick>
{"Submit" |> ste}
</button>;
<button
?id
className={Cn.make((
"button",
"is-fullwidth",
))}
onClick>
{"Submit" |> ste}
</button>;
<button
?id className={Cn.make({ a: b })} onClick>
{"Submit" |> ste}
</button>;
<button
?id className={Cn.make({ "a": b })} onClick>
{"Submit" |> ste}
</button>;
// shouldn't result in a stack overflow
<X y={z->Belt.Option.getWithDefault("")} />;
<div style={getStyle()}>
{ReasonReact.string("BugTest")}
</div>;
<div>
{let left = limit->Int.toString;
{j|$left characters left|j}->React.string}
</div>;
<View style=styles##backgroundImageWrapper>
{let uri = "/images/header-background.png";
<Image
resizeMode=`contain
style=styles##backgroundImage
uri
/>}
</View>;
<div>
{true
? {
let foo = "foo"; // don't remove semi
<span> {ReasonReact.string(foo)} </span>;
}
: <span>
{ReasonReact.string("bar")}
</span>}
</div>;
let v =
<A>
<B>
...{_ => {
let renderX = x =>
{let y = x ++ x;
<div key=y />};
renderX("foo");
}}
</B>
</A>;
<Component
prop={
x->Option.map(x => {
let y = x;
y ++ y;
})
}
/>;
<Component
prop={
name:
x->Option.map(x => {
let y = x;
y ++ y;
}),
}
/>;
<Component
prop={
name:
x
++ Option.map(x => {
let y = x;
y ++ y;
}),
}
/>;
<Component
prop={
name:
x##Option.map(x => {
let y = x;
y ++ y;
}),
}
/>;
<Component
prop={
name:
x
|> Option.map(x => {
let y = x;
y ++ y;
}),
}
/>;
<A someProp={<> {React.string("Hello")} </>} />;
<A someProp=?{<> {React.string("Hi")} </>} />;
<ActionButton
one={!validated} two={msg##errorText}>
<InactionText
three={msg##prop}
four={msg##errorText}
/>
</ActionButton>;
<Foo.bar />;
<Foo.Bar.baz arg="hello" />;
================================================
FILE: test/jsx_functor.t/input.re
================================================
type elt = Text(string) | Group(list(elt));
module X = {
let createElement(~children=[], ()) {
Text("x");
};
};
module Y = {
let createElement(~children=[], ()) {
Text("y");
};
};
module M(X: (module type of X), Y: (module type of Y)) = {
let createElement(~name="M", ~id=0, ~children=[], ()) {
Group([
Text(name),
Text(string_of_int(id)),
<X />,
<Y />
] @ children);
};
};
let _ = Group([
<M(X, Y) />,
<M(X, Y)>
Text("A")
</M>,
<M(X, Y) name="Test" id=10>
</M>
])
================================================
FILE: test/jsx_functor.t/run.t
================================================
Format JSX functors
$ refmt ./input.re
type elt =
| Text(string)
| Group(list(elt));
module X = {
let createElement = (~children=[], ()) => {
Text("x");
};
};
module Y = {
let createElement = (~children=[], ()) => {
Text("y");
};
};
module M =
(
X: (module type of X),
Y: (module type of Y),
) => {
let createElement =
(~name="M", ~id=0, ~children=[], ()) => {
Group(
[
Text(name),
Text(string_of_int(id)),
<X />,
<Y />,
]
@ children,
);
};
};
let _ =
Group([
<M(X, Y) />,
<M(X, Y)> {Text("A")} </M>,
<M(X, Y) name="Test" id=10 />,
]);
================================================
FILE: test/keyword-operators.t/input.re
================================================
/* Keyword operators in parentheses should not be escaped with \# */
let (mod) = mod_float;
let (land) = (land);
let (lor) = (lor);
let (lsl) = (lsl);
let (lsr) = (lsr);
let (lxor) = (lxor);
let (asr) = (asr);
let (or) = (||);
================================================
FILE: test/keyword-operators.t/run.t
================================================
Keyword operators in parentheses should not be escaped with \#
$ refmt ./input.re
/* Keyword operators in parentheses should not be escaped with \# */
let (mod) = mod_float;
let (land) = (land);
let (lor) = (lor);
let (lsl) = (lsl);
let (lsr) = (lsr);
let (lxor) = (lxor);
let (asr) = (asr);
let (or) = (||);
================================================
FILE: test/knownMlIssues.t/input.ml
================================================
(* [x] fixed *)
type t2 =
int * int (* attributed to entire type not binding *)
type color =
| Red of int (* After red *)
| Black of int (* After black *)
| Green of int (* Does not remain here *)
let blahCurriedX x =
function
| Red 10
| Black 20
| Green 10 -> 1 (* After or pattern green *)
| Red x -> 0 (* After red *)
| Black x -> 0 (* After black *)
| Green x -> 0 (* After second green *)
(* On next line after blahCurriedX def *)
(* EOL comments wrap because other elements break first (in this example
"mutable" causes breaks. We either need:
1. To prevent wrapping of anything inside of eol comments attachments.
2. Losslessly wrap eol comments.
*)
(* This example illustrates the above issue, but isn't een idempotent due to the issue. *)
(* type cfg = { *)
(* node_id : int ref; *)
(* node_list : int list ref; *)
(* name_pdesc_tbl : (int, (int, int) Hashtbl.t) Hashtbl.t; (** Map proc name to procdesc *) *)
(* mutable priority_set : (int, int) Hashtbl.t (** set of function names to be analyzed first *) *)
(* } *)
(* *)
(* *)
================================================
FILE: test/knownMlIssues.t/run.t
================================================
Format basic
$ refmt --print re ./input.ml > ./formatted.re
Type-check basics
$ ocamlc -c -pp 'refmt --print binary' -intf-suffix .rei -impl formatted.re
Format the formatted file back
$ refmt --print re ./formatted.re > ./formatted_back.re
Ensure idempotency: first format and second format are the same
$ diff formatted.re formatted_back.re
================================================
FILE: test/knownReIssues.t/input.re
================================================
/**
Issue 940: https://github.com/facebook/reason/issues/940
The parens in the exception match case with an alias,
are required for correct parsing:
i.e. (Sys_error _ as exc) instead of Sys_error _ as exc
The latter doesn't type-check with Error: Unbound value exc.
Warning 11 (unused match case) is also triggered.
*/
let f () = raise(Sys_error("error"));
switch (f ()) {
| x => ()
| exception (Sys_error(_) as exc) => raise(exc)
};
exception Foo(string);
let g () = raise(Foo("bar errors"));
switch (g ()) {
| x => ()
| exception Foo(f) => raise (Foo(f))
};
================================================
FILE: test/knownReIssues.t/run.t
================================================
Format basic
$ refmt --print re ./input.re > ./formatted.re
Print the formatted file
$ cat ./formatted.re
/**
Issue 940: https://github.com/facebook/reason/issues/940
The parens in the exception match case with an alias,
are required for correct parsing:
i.e. (Sys_error _ as exc) instead of Sys_error _ as exc
The latter doesn't type-check with Error: Unbound value exc.
Warning 11 (unused match case) is also triggered.
*/
let f = () => raise(Sys_error("error"));
switch (f()) {
| x => ()
| exception (Sys_error(_) as exc) => raise(exc)
};
exception Foo(string);
let g = () => raise(Foo("bar errors"));
switch (g()) {
| x => ()
| exception (Foo(f)) => raise(Foo(f))
};
Type-check basics
$ ocamlc -c -pp 'refmt --print binary' -intf-suffix .rei -impl formatted.re
Format the formatted file back
$ refmt --print re ./formatted.re > ./formatted_back.re
Ensure idempotency: first format and second format are the same
$ diff formatted.re formatted_back.re
================================================
FILE: test/lazy.t/input.re
================================================
let myComputation = lazy {
let tmp = 10;
let tmp2 = 20;
tmp + tmp2;
};
type myRecord = {myRecordField: int};
let operateOnLazyValue (lazy {myRecordField}) {
let tmp = myRecordField;
tmp + tmp;
};
let result = operateOnLazyValue (lazy {myRecordField: 100});
type box('a) = Box('a);
let lazy thisIsActuallyAPatternMatch = lazy (200);
let tmp: int = thisIsActuallyAPatternMatch;
let (lazy (Box(i)), x) = (lazy (Box(200)), 100);
let tmp: int = i;
let myComputation = lazy (200);
let reallyLoooooooooooooongIdentifierThatSpansMoreThan50Cols = 200;
let foo = lazy(reallyLoooooooooooooongIdentifierThatSpansMoreThan50Cols)
================================================
FILE: test/lazy.t/run.t
================================================
Format basic
$ refmt --print re ./input.re > ./formatted.re
Print the formatted file
$ cat ./formatted.re
let myComputation =
lazy({
let tmp = 10;
let tmp2 = 20;
tmp + tmp2;
});
type myRecord = {myRecordField: int};
let operateOnLazyValue =
(lazy({ myRecordField })) => {
let tmp = myRecordField;
tmp + tmp;
};
let result =
operateOnLazyValue(
lazy({ myRecordField: 100 }),
);
type box('a) =
| Box('a);
let lazy(thisIsActuallyAPatternMatch) =
lazy(200);
let tmp: int = thisIsActuallyAPatternMatch;
let (lazy((Box(i))), x) = (
lazy(Box(200)),
100,
);
let tmp: int = i;
let myComputation = lazy(200);
let reallyLoooooooooooooongIdentifierThatSpansMoreThan50Cols = 200;
let foo =
lazy(
reallyLoooooooooooooongIdentifierThatSpansMoreThan50Cols
);
Type-check basics
$ ocamlc -c -pp 'refmt --print binary' -intf-suffix .rei -impl formatted.re
Format the formatted file back
$ refmt --print re ./formatted.re > ./formatted_back.re
Ensure idempotency: first format and second format are the same
$ diff formatted.re formatted_back.re
================================================
FILE: test/letop.t/input.re
================================================
let (let.opt) = (x, f) => switch x { | None => None | Some(x) => f(x) };
let (let.&opt) = (x, f) => switch x { | None => None | Some(x) => Some(f(x)) };
let z = {
let.opt a = Some(2);
let.&opt b = Some(5);
a + b
}
let (let./\/) = (x, f) => switch x { | None => None | Some(x) => f(x) };
let (let.&/\*) = (x, f) => switch x { | None => None | Some(x) => Some(f(x)) };
/* Test syntax that could potentially conflict with comments */
let z = {
let./\/ a = Some(2);
let.&/\* b = Some(5);
a + b
}
let _ = {
let.opt _ = Some("a");
let.opt _ = Some("c");
// hello
None;
};
// test that the type annotation prints with parenthesis
let _ = {
let.opt (x : string) as _y = Some ("a");
None
};
let x = {
[@foo]
let.opt _ = Some("foo");
None
};
let x = {
/**
* A doc comment
*/
let.opt _ = Some("foo");
None
};
================================================
FILE: test/letop.t/run.t
================================================
Format basic
$ refmt --print re ./input.re > ./formatted.re
Print the formatted file
$ cat ./formatted.re
let (let.opt) = (x, f) =>
switch (x) {
| None => None
| Some(x) => f(x)
};
let (let.&opt) = (x, f) =>
switch (x) {
| None => None
| Some(x) => Some(f(x))
};
let z = {
let.opt a = Some(2);
let.&opt b = Some(5);
a + b;
};
let (let./\/) = (x, f) =>
switch (x) {
| None => None
| Some(x) => f(x)
};
let ( let.&/\* ) = (x, f) =>
switch (x) {
| None => None
| Some(x) => Some(f(x))
};
/* Test syntax that could potentially conflict with comments */
let z = {
let./\/ a = Some(2);
let.&/\* b = Some(5);
a + b;
};
let _ = {
let.opt _ = Some("a");
let.opt _ = Some("c");
// hello
None;
};
// test that the type annotation prints with parenthesis
let _ = {
let.opt (x: string) as _y = Some("a");
None;
};
let x = {
[@foo] let.opt _ = Some("foo");
None;
};
let x = {
/**
* A doc comment
*/
let.opt _ = Some("foo");
None;
};
Type-check basics
$ ocamlc -c -pp 'refmt --print binary' -intf-suffix .rei -impl formatted.re
Format the formatted file back
$ refmt --print re ./formatted.re > ./formatted_back.re
Ensure idempotency: first format and second format are the same
$ diff formatted.re formatted_back.re
================================================
FILE: test/lib/dune
================================================
(rule
(targets outcometreePrinter.ml)
(deps outcometreePrinter.cppo.ml)
(action
(run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets})))
(executable
(name outcometreePrinter)
(libraries reason)
(flags :standard -open StdLabels)
(modules outcometreePrinter))
(executable
(name fdLeak)
(modules fdLeak)
(flags :standard -open StdLabels)
(libraries reason.refmt-lib))
================================================
FILE: test/lib/fdLeak.ml
================================================
open Refmt_lib
let () =
let files = List.init ~len:25 ~f:(fun i -> i) in
let input_file = "./input.re" in
List.iter
~f:(fun _file -> End_of_line.Detect.get_eol_for_file input_file |> ignore)
files;
Format.eprintf "EOL: done@."
================================================
FILE: test/lib/outcometreePrinter.cppo.ml
================================================
(*
* Copyright (c) 2015-present, Facebook, Inc.
*
* This source code is licensed under the MIT license found in the
* LICENSE file in the root directory of this source tree.
*)
(**
* See `testOprint.js` for how this gets run.
*
* In order to test our outcome printer, we parse & typecheck the code provided on stdin.
* That gives us a `Typedtree` (like an AST but with all the types included), which includes
* the `signature` type of the module we just processed.
* From there, `Printtyp` will helpfully convert the `signature` into something that our
* outcome printer can handle.
*
* Outcome printers are mostly used with Repl's like utop or tools like Merlin, so there's
* not a super easy path to "test it out", but this setup is hopefully not too complicated.
*)
open Reason
module ConvertBack = Reason_toolchain.From_current
let main () =
let filename = "./TestTest.ml" in
let modulename = "TestTest" in
let lexbuf = Reason_toolchain.setup_lexbuf ~use_stdin:true filename in
let impl = Reason_toolchain.RE.implementation in
#if OCAML_VERSION >= (4,9,0)
Compmisc.init_path ();
#else
Compmisc.init_path false;
#endif
#if OCAML_VERSION >= (5,3,0)
Env.set_current_unit (Unit_info.make ~source_file:filename Impl modulename);
#else
Env.set_unit_name modulename;
#endif
let ast = impl lexbuf in
let ast = Reason_toolchain.To_current.copy_structure ast in
let env = Compmisc.initial_env() in
#if OCAML_VERSION >= (4,13,0)
let { Typedtree.structure = typedtree; _ } =
#else
let (typedtree, _) =
#endif
Typemod.type_implementation
#if OCAML_VERSION >= (5,3,0)
(Unit_info.make ~source_file:modulename Impl modulename)
#elif OCAML_VERSION >= (5,2,0)
(Unit_info.make ~source_file:modulename modulename)
#else
modulename modulename modulename
#endif
env ast
in
#if OCAML_VERSION >= (5,3,0)
let tree = Out_type.tree_of_signature typedtree.Typedtree.str_type in
#else
let tree = Printtyp.tree_of_signature typedtree.Typedtree.str_type in
#endif
let phrase = (Reason_omp.Ast_414.Outcometree.Ophr_signature
(List.map ~f:(fun item -> (ConvertBack.copy_out_sig_item item, None)) tree)
) in
let fmt = Format.str_formatter in
Reason_oprint.print_out_phrase fmt phrase;
let result = Format.flush_str_formatter () in
print_string result
let () = main ()
================================================
FILE: test/lineComments.t/input.re
================================================
3; // -
3 //-
;
3//-
;
3/*-*/;
// **** comment
/*** comment */
/** docstring */
// comment
/** docstring */
/*** comment */
/**** comment */
/***** comment */
/** */
/*** */
/**** */
/**/
/***/
/****/
/** (** comment *) */
/** (*** comment *) */
// (** comment *)
// (*** comment *)
// *(*** comment *)
// comment *
// comment **
// comment ***
// comment ****
/**
* Multiline
*/
/** Multiline
*
*/
/**
**
*/
module JustString = {
include Map.Make(Int32); // Comment eol include
};
let testingEndOfLineComments =
[
"Item 1" /* Comment For First Item */,
"Item 2" /* Comment For Second Item */,
"Item 3" /* Comment For Third Item */,
"Item 4" /* Comment For Fourth Item - but before trailing comma */,
// Comment after last item in list.
] /* Comment after rbracket */;
// But if you place them after the comma at eol, they're preserved as such
let testingEndOfLineComments =
[
"Item 1", // Comment For First Item
"Item 2", // Comment For Second Item
"Item 3", // Comment For Third Item
"Item 4" /* Comment For Fourth Item - but before trailing comma */,
// Comment after last item in list.
] /* Comment after rbracket */ ;
// The space between ; and comment shoudn't matter
let testPlacementOfTrailingComment = [
"Item 0" //
// Comment after last item in list.
]; // Comment after semi
// The space between ; and comment shoudn't matter
let testPlacementOfTrailingComment = [
"Item 0" //
// Comment after last item in list.
];// Comment after semi
// Try again but without other things in the list
let testPlacementOfTrailingComment = [
"Item 0" //
]; // Comment after semi
// The space between ; and comment shoudn't matter
let testPlacementOfTrailingComment = [
"Item 0" //
// Comment after last item in list.
];// Comment after semi
let testingEndOfLineComments = [];// Comment after entire let binding
// The following is not yet idempotent
// let myFunction
// withFirstArg // First arg
// andSecondArg => { // Second Arg
// withFirstArg + andSecondArg /* before semi */ ;
// };
let myFunction
(// First arg
withFirstArg,
// Second Arg
andSecondArg) {
withFirstArg + andSecondArg
}; // After Semi
type point = {
x: string, // x field
y: string, // y field
};
type pointWithManyKindsOfComments = {
// Line before x
x: string, // x field
// Line before y
y: string, // y field
// Final row of record
};
type typeParamPointWithComments('a) = {
// Line before x
x: 'a, // x field
// Line before y
y: 'a // y field
// Final row of record
};
// Now, interleaving comments in type params
type
// Type name
typeParamPointWithComments2(
// The a type param
'a,
// The b type apram
'b) = {
// Line before x
x: 'a, // x field
// Line before y
y: 'a // y field
// Final row of record
};
/* The way the last row comment is formatted is suboptimal becuase
* record type definitions do not include enough location information */
type anotherpoint = {
x: string, // x field
y: string, // y field
// comment as last row of record
};
type t = (int, int); // End of line on t
type t2 =
(int, int) // End of line on (int, int)
;
type t3 =
(int, int); // End of line on (int, int)
type variant =
| X (int, int) // End of line on X
| Y (int, int); // End of line on Y
// Comment on entire type def for variant
// Before let
let res =
// Before switch
switch (X (2, 3)) {
// Above X line
| X(_) => "result of X" // End of arrow and X line
// Above Y line
| Y(_) => "result of Y" // End of arrow and Y line
}; // After final semi in switch
let res =
switch (X (2, 3)) {
| X (0, 0) => // After X arrow
"result of X" // End of X body line
| X (1, 0) /* Before X's arrow */ =>
"result of X" // End of X body line
| X (_) => // After X _ arrow
"result of X" // End of X body line
// Above Y line
| Y (_) =>
// Comment above Y body
"result of Y"
};
type variant2 =
// Comment above X
| X (int, int) // End of line on X
// Comment above Y
| Y (int, int);
type variant3 =
// Comment above X
| X (int, int) // End of line on X
// Comment above Y
| Y (int, int) // End of line on Y
;
type x = { // not attached *above* x
fieldOne : int,
fieldA : int
} // Attached end of line after x
and y = { // not attached *above* y
fieldTwo : int
} // Attached end of line after y
;
type x2 = { // not attached *above* x2
fieldOne : int,
fieldA : int
} // Attached end of line after x2
and y2 = { // not attached *above* y2
fieldTwo : int
};
let result =
switch (None) {
| Some({fieldOne: 20, fieldA:a})=> // Where does this comment go?
let tmp = 0;
2 + tmp
| Some {fieldOne: n, fieldA:a} =>
// How about this one
let tmp = n;
n + tmp
| None => 20
};
let res =
// Before switch
switch (X (2, 3)) {
// Above X line
| X(_) => "result of X" // End of arrow and X line
// Above Y line
| Y(_) => "result of Y" // End of arrow and Y line
};
/*
* Now these end of line comments *should* be retained.
*/
let result = switch (None) {
| Some {
fieldOne: 20, // end of line
fieldA:a // end of line
} =>
let tmp = 0;
2 + tmp
| Some {
fieldOne: n, // end of line
fieldA:a // end of line
} =>
let tmp = n;
n + tmp
| None => 20
};
/*
* These end of line comments *should* be retained.
* To get the simple expression eol comment to be retained, we just need to
* implement label breaking eol behavior much like we did with sequences.
* Otherwise, right now they are not idempotent.
*/
let res =
switch ( // Retain this
X (2, 3)
)
{
// Above X line
| X (
_, // retain this
_ // retain this
) => "result of X"
// Above Y line
| Y(_) => "result of Y" // End of arrow and Y line
};
type optionalTuple =
| OptTup (
option ((
int, // First int
int // Second int
))
);
type optionTuple =
option ((
int, // First int
int // Second int
));
type intPair = (
int, // First int
int // Second int
);
type intPair2 = (
// First int
int,
// Second int
int
);
let result = {
/**/
(+)(2,3)
};
// This is not yet idempotent
// {
// /**/
// (+) 2 3
// };
let a = ();
for (i in 0 to 10) {
// bla
a
};
if (true) {
// hello
()
};
type color =
| Red(int) // After red end of line
| Black(int) // After black end of line
| Green(int); // After green end of line
// On next line after color type def
let blahCurriedX(x) =
fun
| Red(10)
| Black(20)
| Green(10) => 1 // After or pattern green
| Red(x) => 0 // After red
| Black(x) => 0 // After black
| Green(x) => 0; // After second green
// On next line after blahCurriedX def
let name_equal(x,y) { x == y };
let equal(i1,i2) =
i1.contents === i2.contents && true; // most unlikely first
let equal(i1,i2) =
compare(compare(0,0),compare(1,1)); // END OF LINE HERE
let tuple_equal((i1, i2)) = i1 == i2;
let tuple_equal((csu, mgd)) =
// Some really long comments, see https://github.com/facebook/reason/issues/811
tuple_equal((csu, mgd));
/** Comments inside empty function bodies
* See https://github.com/facebook/reason/issues/860
*/
let fun_def_comment_inline = () => { /* */ };
let fun_def_comment_newline = () => {
//
};
let fun_def_comment_long = () => { /* longer comment inside empty function body */};
let trueThing = true;
for (i in 0 to 1) {
// comment
print_newline();
};
while (trueThing) {
// comment
print_newline();
};
if (trueThing) {
// comment
print_newline()
};
// Comment before if test
if (trueThing) {
// Comment before print
print_newline();
// Comment before print
print_newline();
// Comment after final print
};
// Comment before if test
if (trueThing) {
// Comment before print
print_newline();
// Comment after final print
};
// Comment before if test
if (trueThing) {
// Comment before print
print_newline();
// Comment before print
print_newline();
// Comment after final print
} else {
// Comment before print
print_newline();
// Comment before print
print_newline();
// Comment after final print
};
// Comment before if test
if (trueThing) {
// Comment before print
print_newline();
// Comment after final print
} else {
// Comment before print
print_newline();
// Comment after final print
};
// Comment before while test
while (trueThing) {
// Comment before print
print_newline();
// Comment before print
print_newline();
// Comment after final print
};
// Comment before while test
while (trueThing) {
// Comment before print
print_newline();
// Comment after final print
};
// Comment before for test
for (i in 0 to 100) {
// Comment before print
print_newline();
// Comment before print
print_newline();
// Comment after final print
};
// Comment before for test
for (i in 0 to 100) {
// Comment before print
print_newline();
// Comment after final print
};
if (trueThing) {
// Comment before print
print_newline(); // eol print
// Comment before print
print_newline(); // eol print
// Comment after print
};
// Comment before if test
if (trueThing) {
// Comment before print
print_newline(); // eol print
// Comment after print
};
// Comment before if test
if (trueThing) {
// Comment before print
print_newline(); // eol print
// Comment before print
print_newline(); // eol print
// Comment after print
} else {
// Comment before print
print_newline(); // eol print
// Comment before print
print_newline(); // eol print
// Comment after print
};
// Comment before if test
if (trueThing) {
// Comment before print
print_newline(); // eol print
// Comment before print
} else {
// Comment before print
print_newline(); // eol print
// Comment before print
print_newline(); // eol print
// Comment after print
};
// Comment before while test
while (trueThing) {
// Comment before print
print_newline(); // eol
// Comment before print
print_newline(); // eol
// Comment after final print
};
// Comment before while test
while (trueThing) {
// Comment before print
print_newline(); // eol
// Comment after final print
};
// Comment before for test
for (i in 0 to 100) {
// Comment before print
print_newline(); // eol
// Comment before print
print_newline(); // eol
// Comment after final print
};
// Comment before for test
for (i in 0 to 100) {
// Comment before print
print_newline(); // eol
// Comment after final print
};
let f = (a, b, c, d) => a + b + c + d;
while(trueThing) {
f(
// a
1,
// b
2,
// c
3,
// d
4
// does work
);
};
while(trueThing) {
f(
// a
1,
// b
2,
// c
3,
// d
4 // does work
);
};
ignore((_really, _long, _printWidth, _exceeded, _here) => {
// First comment
let x = 0;
x + x;
// Closing comment
});
ignore((_xxx, _yyy) => {
// First comment
let x = 0;
x + x;
// Closing comment
});
type tester('a, 'b) = | TwoArgsConstructor('a, 'b) | OneTupleArgConstructor(('a, 'b));
let callFunctionTwoArgs = (a, b) => ();
let callFunctionOneTuple = (tuple) => ();
let y = TwoArgsConstructor(
1, //eol1
2 // eol2
);
let y = callFunctionTwoArgs(
1, //eol1
2 // eol2
);
let y = OneTupleArgConstructor((
1, //eol1
2 // eol2
));
let y = callFunctionOneTuple((
1, //eol1
2 // eol2
));
type polyRecord('a, 'b) = {fieldOne: 'a, fieldTwo: 'b};
let r = {
fieldOne: 1, //eol1
fieldTwo: 2 // eol2
};
let r = {
fieldOne: 1, //eol1
fieldTwo: 2, // eol2 with trailing comma
};
let y = TwoArgsConstructor(
"1", //eol1
"2" // eol2
);
let y = callFunctionTwoArgs(
"1", //eol1
"2" // eol2
);
let y = OneTupleArgConstructor((
"1", //eol1
"2" // eol2
));
let y = callFunctionOneTuple((
"1", //eol1
"2" // eol2
));
let r = {
fieldOne: "1", //eol1
fieldTwo: "2" // eol2
};
let r = {
fieldOne: "1", //eol1
fieldTwo: "2", // eol2 with trailing comma
};
let identifier = "hello";
let y = TwoArgsConstructor(
identifier, //eol1
identifier // eol2
);
let y = callFunctionTwoArgs(
identifier , //eol1
identifier // eol2
);
let y = OneTupleArgConstructor((
identifier , //eol1
identifier // eol2
));
let y = callFunctionOneTuple((
identifier , //eol1
identifier // eol2
));
let r = {
fieldOne: identifier, //eol1
fieldTwo: identifier // eol2
};
let r = {
fieldOne: identifier, //eol1
fieldTwo: identifier, // eol2 with trailing comma
};
let y = TwoArgsConstructor(
identifier : string, //eol1
identifier : string// eol2
);
let y = callFunctionTwoArgs(
identifier : string , //eol1
identifier : string // eol2
);
let y = OneTupleArgConstructor((
identifier : string , //eol1
identifier : string // eol2
));
let y = callFunctionOneTuple((
identifier : string , //eol1
identifier : string // eol2
));
let r = {
fieldOne: (identifier : string), //eol1
fieldTwo: (identifier : string) // eol2
};
let r = {
fieldOne: (identifier : string), //eol1
fieldTwo: (identifier : string), // eol2 with trailing comma
};
// whitespace interleaving
// comment1
// comment2
// whitespace above & below
let r = {
fieldOne: (identifier : string), //eol1
// c1
// c2
// c3
// c4
// c5
fieldTwo: (identifier : string), // eol2 with trailing comma
};
// trailing
// trailing whitespace above
// attach
// last comment
================================================
FILE: test/lineComments.t/run.t
================================================
Format line comments
$ refmt ./input.re
3; // -
3; //-
3; //-
3 /*-*/;
// **** comment
/*** comment */
/** docstring */
// comment
/** docstring */
/*** comment */
/**** comment */
/***** comment */
/** */
/*** */
/**** */
/**/
/***/
/****/
/** (** comment *) */
/** (*** comment *) */
// (** comment *)
// (*** comment *)
// *(*** comment *)
// comment *
// comment **
// comment ***
// comment ****
/**
* Multiline
*/
/** Multiline
*
*/
/**
**
*/
module JustString = {
include Map.Make(Int32); // Comment eol include
};
let testingEndOfLineComments = [
"Item 1" /* Comment For First Item */,
"Item 2" /* Comment For Second Item */,
"Item 3" /* Comment For Third Item */,
"Item 4" /* Comment For Fourth Item - but before trailing comma */,
// Comment after last item in list.
] /* Comment after rbracket */;
// But if you place them after the comma at eol, they're preserved as such
let testingEndOfLineComments = [
"Item 1", // Comment For First Item
"Item 2", // Comment For Second Item
"Item 3", // Comment For Third Item
"Item 4" /* Comment For Fourth Item - but before trailing comma */,
// Comment after last item in list.
] /* Comment after rbracket */;
// The space between ; and comment shoudn't matter
let testPlacementOfTrailingComment = [
"Item 0" //
// Comment after last item in list.
]; // Comment after semi
// The space between ; and comment shoudn't matter
let testPlacementOfTrailingComment = [
"Item 0" //
// Comment after last item in list.
]; // Comment after semi
// Try again but without other things in the list
let testPlacementOfTrailingComment = [
"Item 0" //
]; // Comment after semi
// The space between ; and comment shoudn't matter
let testPlacementOfTrailingComment = [
"Item 0" //
// Comment after last item in list.
]; // Comment after semi
let testingEndOfLineComments = []; // Comment after entire let binding
// The following is not yet idempotent
// let myFunction
// withFirstArg // First arg
// andSecondArg => { // Second Arg
// withFirstArg + andSecondArg /* before semi */ ;
// };
let myFunction = // First arg
(
withFirstArg,
// Second Arg
andSecondArg,
) => {
withFirstArg + andSecondArg;
}; // After Semi
type point = {
x: string, // x field
y: string // y field
};
type pointWithManyKindsOfComments = {
// Line before x
x: string, // x field
// Line before y
y: string // y field
// Final row of record
};
type typeParamPointWithComments('a) = {
// Line before x
x: 'a, // x field
// Line before y
y: 'a // y field
// Final row of record
};
// Now, interleaving comments in type params
// Type name
type typeParamPointWithComments2
// The a type param
(
'a,
// The b type apram
'b,
) = {
// Line before x
x: 'a, // x field
// Line before y
y: 'a // y field
// Final row of record
};
/* The way the last row comment is formatted is suboptimal becuase
* record type definitions do not include enough location information */
type anotherpoint = {
x: string, // x field
y: string // y field
// comment as last row of record
};
type t = (int, int); // End of line on t
type t2 = (int, int); // End of line on (int, int)
type t3 = (int, int); // End of line on (int, int)
type variant =
| X(int, int) // End of line on X
| Y(int, int); // End of line on Y
// Comment on entire type def for variant
// Before let
let res =
// Before switch
switch (X(2, 3)) {
// Above X line
| X(_) => "result of X" // End of arrow and X line
// Above Y line
| Y(_) => "result of Y" // End of arrow and Y line
}; // After final semi in switch
let res =
switch (X(2, 3)) {
| X(0, 0) =>
// After X arrow
"result of X" // End of X body line
| X(1, 0) /* Before X's arrow */ => "result of X" // End of X body line
| X(_) =>
// After X _ arrow
"result of X" // End of X body line
// Above Y line
| Y(_) =>
// Comment above Y body
"result of Y"
};
type variant2 =
// Comment above X
| X(int, int) // End of line on X
// Comment above Y
| Y(int, int);
type variant3 =
// Comment above X
| X(int, int) // End of line on X
// Comment above Y
| Y(int, int); // End of line on Y
type x = {
// not attached *above* x
fieldOne: int,
fieldA: int,
} // Attached end of line after x
and y = {
// not attached *above* y
fieldTwo: int,
}; // Attached end of line after y
type x2 = {
// not attached *above* x2
fieldOne: int,
fieldA: int,
} // Attached end of line after x2
and y2 = {
// not attached *above* y2
fieldTwo: int,
};
let result =
switch (None) {
| Some({ fieldOne: 20, fieldA: a }) =>
// Where does this comment go?
let tmp = 0;
2 + tmp;
| Some({ fieldOne: n, fieldA: a }) =>
// How about this one
let tmp = n;
n + tmp;
| None => 20
};
let res =
// Before switch
switch (X(2, 3)) {
// Above X line
| X(_) => "result of X" // End of arrow and X line
// Above Y line
| Y(_) => "result of Y" // End of arrow and Y line
};
/*
* Now these end of line comments *should* be retained.
*/
let result =
switch (None) {
| Some({
fieldOne: 20, // end of line
fieldA: a // end of line
}) =>
let tmp = 0;
2 + tmp;
| Some({
fieldOne: n, // end of line
fieldA: a // end of line
}) =>
let tmp = n;
n + tmp;
| None => 20
};
/*
* These end of line comments *should* be retained.
* To get the simple expression eol comment to be retained, we just need to
* implement label breaking eol behavior much like we did with sequences.
* Otherwise, right now they are not idempotent.
*/
let res =
switch (
// Retain this
X(2, 3)
) {
// Above X line
| X(
_, // retain this
_ // retain this
) => "result of X"
// Above Y line
| Y(_) => "result of Y" // End of arrow and Y line
};
type optionalTuple =
| OptTup(
option(
(
int, // First int
int // Second int
),
),
);
type optionTuple =
option(
(
int, // First int
int // Second int
),
);
type intPair = (
int, // First int
int // Second int
);
type intPair2 = (
// First int
int,
// Second int
int,
);
let result =
/**/
{
2 + 3;
};
// This is not yet idempotent
// {
// /**/
// (+) 2 3
// };
let a = ();
for (i in 0 to 10) {
// bla
a;
};
if (true) {
// hello
()
};
type color =
| Red(int) // After red end of line
| Black(int) // After black end of line
| Green(int); // After green end of line
// On next line after color type def
let blahCurriedX = x =>
fun
| Red(10)
| Black(20)
| Green(10) => 1 // After or pattern green
| Red(x) => 0 // After red
| Black(x) => 0 // After black
| Green(x) => 0; // After second green
// On next line after blahCurriedX def
let name_equal = (x, y) => {
x == y;
};
let equal = (i1, i2) =>
i1.contents === i2.contents && true; // most unlikely first
let equal = (i1, i2) =>
compare(compare(0, 0), compare(1, 1)); // END OF LINE HERE
let tuple_equal = ((i1, i2)) => i1 == i2;
let tuple_equal = ((csu, mgd)) =>
// Some really long comments, see https://github.com/facebook/reason/issues/811
tuple_equal((csu, mgd));
/** Comments inside empty function bodies
* See https://github.com/facebook/reason/issues/860
*/
let fun_def_comment_inline = () => {/* */};
let fun_def_comment_newline = () => {
//
};
let fun_def_comment_long = () => {
/* longer comment inside empty function body */
};
let trueThing = true;
for (i in 0 to 1) {
// comment
print_newline();
};
while (trueThing) {
// comment
print_newline();
};
if (trueThing) {
// comment
print_newline();
};
// Comment before if test
if (trueThing) {
// Comment before print
print_newline();
// Comment before print
print_newline();
// Comment after final print
};
// Comment before if test
if (trueThing) {
// Comment before print
print_newline();
// Comment after final print
};
// Comment before if test
if (trueThing) {
// Comment before print
print_newline();
// Comment before print
print_newline();
// Comment after final print
} else {
// Comment before print
print_newline();
// Comment before print
print_newline();
// Comment after final print
};
// Comment before if test
if (trueThing) {
// Comment before print
print_newline();
// Comment after final print
} else {
// Comment before print
print_newline();
// Comment after final print
};
// Comment before while test
while (trueThing) {
// Comment before print
print_newline();
// Comment before print
print_newline();
// Comment after final print
};
// Comment before while test
while (trueThing) {
// Comment before print
print_newline();
// Comment after final print
};
// Comment before for test
for (i in 0 to 100) {
// Comment before print
print_newline();
// Comment before print
print_newline();
// Comment after final print
};
// Comment before for test
for (i in 0 to 100) {
// Comment before print
print_newline();
// Comment after final print
};
if (trueThing) {
// Comment before print
print_newline(); // eol print
// Comment before print
print_newline(); // eol print
// Comment after print
};
// Comment before if test
if (trueThing) {
// Comment before print
print_newline(); // eol print
// Comment after print
};
// Comment before if test
if (trueThing) {
// Comment before print
print_newline(); // eol print
// Comment before print
print_newline(); // eol print
// Comment after print
} else {
// Comment before print
print_newline(); // eol print
// Comment before print
print_newline(); // eol print
// Comment after print
};
// Comment before if test
if (trueThing) {
// Comment before print
print_newline(); // eol print
// Comment before print
} else {
// Comment before print
print_newline(); // eol print
// Comment before print
print_newline(); // eol print
// Comment after print
};
// Comment before while test
while (trueThing) {
// Comment before print
print_newline(); // eol
// Comment before print
print_newline(); // eol
// Comment after final print
};
// Comment before while test
while (trueThing) {
// Comment before print
print_newline(); // eol
// Comment after final print
};
// Comment before for test
for (i in 0 to 100) {
// Comment before print
print_newline(); // eol
// Comment before print
print_newline(); // eol
// Comment after final print
};
// Comment before for test
for (i in 0 to 100) {
// Comment before print
print_newline(); // eol
// Comment after final print
};
let f = (a, b, c, d) => a + b + c + d;
while (trueThing) {
f(
// a
1,
// b
2,
// c
3,
// d
4,
// does work
);
};
while (trueThing) {
f(
// a
1,
// b
2,
// c
3,
// d
4 // does work
);
};
ignore(
(
_really,
_long,
_printWidth,
_exceeded,
_here,
) => {
// First comment
let x = 0;
x + x;
// Closing comment
});
ignore((_xxx, _yyy) => {
// First comment
let x = 0;
x + x;
// Closing comment
});
type tester('a, 'b) =
| TwoArgsConstructor('a, 'b)
| OneTupleArgConstructor(('a, 'b));
let callFunctionTwoArgs = (a, b) => ();
let callFunctionOneTuple = tuple => ();
let y =
TwoArgsConstructor(
1, //eol1
2 // eol2
);
let y =
callFunctionTwoArgs(
1, //eol1
2 // eol2
);
let y =
OneTupleArgConstructor((
1, //eol1
2 // eol2
));
let y =
callFunctionOneTuple((
1, //eol1
2 // eol2
));
type polyRecord('a, 'b) = {
fieldOne: 'a,
fieldTwo: 'b,
};
let r = {
fieldOne: 1, //eol1
fieldTwo: 2 // eol2
};
let r = {
fieldOne: 1, //eol1
fieldTwo: 2 // eol2 with trailing comma
};
let y =
TwoArgsConstructor(
"1", //eol1
"2" // eol2
);
let y =
callFunctionTwoArgs(
"1", //eol1
"2" // eol2
);
let y =
OneTupleArgConstructor((
"1", //eol1
"2" // eol2
));
let y =
callFunctionOneTuple((
"1", //eol1
"2" // eol2
));
let r = {
fieldOne: "1", //eol1
fieldTwo: "2" // eol2
};
let r = {
fieldOne: "1", //eol1
fieldTwo: "2" // eol2 with trailing comma
};
let identifier = "hello";
let y =
TwoArgsConstructor(
identifier, //eol1
identifier // eol2
);
let y =
callFunctionTwoArgs(
identifier, //eol1
identifier // eol2
);
let y =
OneTupleArgConstructor((
identifier, //eol1
identifier // eol2
));
let y =
callFunctionOneTuple((
identifier, //eol1
identifier // eol2
));
let r = {
fieldOne: identifier, //eol1
fieldTwo: identifier // eol2
};
let r = {
fieldOne: identifier, //eol1
fieldTwo: identifier // eol2 with trailing comma
};
let y =
TwoArgsConstructor(
identifier: string, //eol1
identifier: string // eol2
);
let y =
callFunctionTwoArgs(
identifier: string, //eol1
identifier: string // eol2
);
let y =
OneTupleArgConstructor((
identifier: string, //eol1
identifier: string // eol2
));
let y =
callFunctionOneTuple((
identifier: string, //eol1
identifier: string // eol2
));
let r = {
fieldOne: (identifier: string), //eol1
fieldTwo: (identifier: string) // eol2
};
let r = {
fieldOne: (identifier: string), //eol1
fieldTwo: (identifier: string) // eol2 with trailing comma
};
// whitespace interleaving
// comment1
// comment2
// whitespace above & below
let r = {
fieldOne: (identifier: string), //eol1
// c1
// c2
// c3
// c4
// c5
fieldTwo: (identifier: string) // eol2 with trailing comma
};
// trailing
// trailing whitespace above
// attach
// last comment
================================================
FILE: test/melange-support.t/input.re
================================================
bla#=10;
bla#=Some(10);
bla#=someFunc(Some(10));
test##var#=Some(-10);
obj##.prop;
obj##.prod := exp;
preview##style##border#=Js.string("1px black dashed");
(preview##(style##border)#=args)(somenum);
(x##y)##z#=((xxxx##yyyy)##zzzz);
let result = js_method_run1((!react)#createElement,foo);
add(zz##yy,xx##ww);
/* These should print the same */
let res = ((x##y) + (z##q)); /* AST */
let res = x##y + z##q; /* Minimum parens */
/* These should print the same */
let res = (y + (z##q)##a); /* AST */
let res = y + z##q##a; /* Min parens */
/* Make sure it's actually parsed as left precedence
* and that is maintained when printed */
let res = (z##(q##a)); /* AST */
let res = z##(q##a); /* Min parens */
/* These should print the same */
let res = (! (x##y)); /* AST */
let res = !x##y; /* Minimum parens */
/* These should print the same */
let res = (!(z##q)##a); /* AST */
let res = !z##q##a; /* Min parens */
/* These should print the same */
let res = (?!! (x##y)); /* AST */
let res = ?!!x##y; /* Minimum parens */
/* These should print the same */
let res = (?!!z##(q##a)); /* AST */
let res = ?!!z##(q##a); /* Min parens */
res #= ?!!z ## q;
res #= ?!!z##(q##a);
let result = myFunction(x(y)## z, a(b)#= c);
(!x)##y##(b##c);
type a = Js.t({. foo: bar});
let a = {"key": 10};
let b = {"nested": {"objs": {"are": {"nice": "<3"}}}};
let c = {"a": a, "b": b, "func": fun(a)=> a##c#=func(10)};
let d = {"a": a2, "b": b , "func": fun(a)=> {"a": (fun(arg1,arg2)=> arg1 + arg2)}};
let a = {"/foo": 10};
let isArrayPolyfill: [@bs] ((int) => bool) = [%bs.raw
"function(a) {return Object.prototype.toString.call(a) === '[object Array]'}"
];
this#arrayInObject[count] = 1;
type y = {.
[@bs.set no_get] "height" : int,
[@bs.set no_get] "width" : int
};
type y = {
.
[@foo barbaz] "heightThatIsASuperLongStringForceBreak": int => unit,
[@foo barbaz] "widthThatIsASuperLongStringForceBreak": int => unit,
};
type y = {
.
[@foo barbaz] "width": (int, int, int, float, float, float) => unit,
[@foo barbaz] "height": (int, int, int, float, float, float) => unit,
};
/* https://github.com/facebook/reason/issues/2121 */
Style.( { "container": 3 });
================================================
FILE: test/melange-support.t/run.t
================================================
Format Melange-specific support
$ refmt ./input.re
bla #= 10;
bla #= Some(10);
bla #= someFunc(Some(10));
test##var #= Some(-10);
obj##.prop;
obj##.prod := exp;
preview##style##border
#= Js.string("1px black dashed");
(preview##(style##border) #= args)(somenum);
x##y##z #= xxxx##yyyy##zzzz;
let result =
js_method_run1((!react)#createElement, foo);
add(zz##yy, xx##ww);
/* These should print the same */
let res = x##y + z##q; /* AST */
let res = x##y + z##q; /* Minimum parens */
/* These should print the same */
let res = y + z##q##a; /* AST */
let res = y + z##q##a; /* Min parens */
/* Make sure it's actually parsed as left precedence
* and that is maintained when printed */
let res = z##(q##a); /* AST */
let res = z##(q##a); /* Min parens */
/* These should print the same */
let res = !x##y; /* AST */
let res = !x##y; /* Minimum parens */
/* These should print the same */
let res = !z##q##a; /* AST */
let res = !z##q##a; /* Min parens */
/* These should print the same */
let res = ?!!x##y; /* AST */
let res = ?!!x##y; /* Minimum parens */
/* These should print the same */
let res = ?!!z##(q##a); /* AST */
let res = ?!!z##(q##a); /* Min parens */
res #= ?!!z##q;
res #= ?!!z##(q##a);
let result = myFunction(x(y)##z, a(b) #= c);
(!x)##y##(b##c);
type a = {. "foo": bar };
let a = { "key": 10 };
let b = {
"nested": {
"objs": {
"are": {
"nice": "<3",
},
},
},
};
let c = {
"a": a,
"b": b,
"func": a => a##c #= func(10),
};
let d = {
"a": a2,
"b": b,
"func": a => {
"a": (arg1, arg2) => arg1 + arg2,
},
};
let a = { "/foo": 10 };
let isArrayPolyfill: (. int) => bool = [%bs.raw
"function(a) {return Object.prototype.toString.call(a) === '[object Array]'}"
];
this#arrayInObject[count] = 1;
type y = {
.
[@bs.set no_get] "height": int,
[@bs.set no_get] "width": int,
};
type y = {
.
[@foo barbaz]
"heightThatIsASuperLongStringForceBreak":
int => unit,
[@foo barbaz]
"widthThatIsASuperLongStringForceBreak":
int => unit,
};
type y = {
.
[@foo barbaz]
"width":
(int, int, int, float, float, float) => unit,
[@foo barbaz]
"height":
(int, int, int, float, float, float) => unit,
};
/* https://github.com/facebook/reason/issues/2121 */
Style.{ "container": 3 };
================================================
FILE: test/mlFunctions.t/input.ml
================================================
(* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. *)
let x =
ignore (fun y ->
let y = 4 in
y)
================================================
FILE: test/mlFunctions.t/run.t
================================================
Format basic
$ refmt ./input.ml | tee formatted.re
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
let x =
ignore(y => {
let y = 4;
y;
});
Format the formatted file back
$ refmt ./formatted.re | tee formatted_back.re
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
let x =
ignore(y => {
let y = 4;
y;
});
Ensure idempotency: first format and second format are the same
$ diff formatted.re formatted_back.re
================================================
FILE: test/mlVariants.t/input.ml
================================================
(* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. *)
type polyVariantsInMl = [
| `IntTuple of (int * int)
| `StillAnIntTuple of (int * int)
]
let intTuple = `IntTuple (1, 2)
let stillAnIntTuple = `StillAnIntTuple (4, 5)
let sumThem = function
| `IntTuple (x, y) -> x + y
| `StillAnIntTuple (a, b) -> a + b
type nonrec t = A of int | B of bool
type s = [ `Poly ]
let x = (`Poly: s)
(* There's a bug in ocaml 4.06 resulting in an extra Pexp_constraint on the `Poly,
* duplicating the core_type.
* https://caml.inria.fr/mantis/view.php?id=7758
* https://caml.inria.fr/mantis/view.php?id=7344 *)
let x : s = `Poly
================================================
FILE: test/mlVariants.t/run.t
================================================
Format basic
$ refmt --print re ./input.ml > ./formatted.re
Type-check basics
$ ocamlc -c -pp 'refmt --print binary' -intf-suffix .rei -impl formatted.re
Format the formatted file back
$ refmt --print re ./formatted.re > ./formatted_back.re
Ensure idempotency: first format and second format are the same
$ diff formatted.re formatted_back.re
================================================
FILE: test/modules.t/input.re
================================================
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
let run = fun () => {
TestUtils.printSection("Modules");
};
/**
* Modules:
* ----------------------------------------------------------------------------
* Modules accomplish the following:
* - Organization of code and data.
* - Basis for separate compilation and fast compile times.
* - Enabled higher order type abstractions that are capable of modelling very
* sophisticated typing relationships between various parts of your code.
*
* Modules are much like records, but much more powerful. Much of modules'
* powers are derived from the fact that they are primarily built up and
* organized at compilation time, instead of runtime. It is this constraint
* that allows modules to be more powerful than simple records.
*
* There are some important ways that modules differ from records:
*
* - Fields are lexically scoped: In the following record: `{x:1, y: x + x}`,
* the reference to `x` does not refer to the record field `x`. This is because
* records fields do not form lexical scopes for the evaluation of other record
* values. Modules, on the other hand do allow fields to reference other
* fields. Appropriately, each field is introduced via the keyword `let`.
*/
module MyFirstModule = {
let x = 0;
let y = x + x;
};
let result = MyFirstModule.x + MyFirstModule.y;
/**
* - A module is introduced with the `module` phrase.
* - A module *must* have a capital letter as its first character.
* - The exported fields of a module must be listed within `{}` braces and each
* exported value binding is specified via a `let` keyword.
*/
/**
* Another way that modules are more powerful than records, is that they may
* also export types.
*/
module MySecondModule = {
type someType = int;
let x = 0;
let y = x + x;
};
let myInt:MySecondModule.someType = 100;
/** Module signatures:
* ----------------------------------------------------------------------------
* Not only may modules export types, but modules *themselves* can be described
* by types via the `module type` phrase. We call these module types
* "signatures". For example, `MySecondModule` has the following `module type`
* signature:
*/
module type MySecondModuleType = {
type someType = int;
let x: int;
let y: int;
};
/**
* Much like how you can ensure that a value is compatible with a specific
* type:
let myTestVal: int = 10;
* You can also perform the same type of annotation to ensure that you have
* written code that matches your understanding. For example, `MySecondModule`
* could have been written as:
module MySecondModule: MySecondModuleType = {
type someType = int;
let x = 0;
let y = x + x;
};
*/
/**
* - Modules may be artificially "constrained" so that users of a module see
* fewer details than are actually present.
* - Modules may be combined, merged, and transformed at compile time in ways
* that
* - Because they are more powerful, they may not be passed around at runtime
* as easily as records.
*
* Some additioal benefits to using modules:
* - Modules are a very elegant way to organize large packages of code.
* - Modules are the unit of compilation. Minimal recompilation changes
* - Modules can help you achieve higher degrees of polymorphism than the core
* language.
*/
let opensAModuleLocally = {
module MyLocalModule = {
type i = int;
let x:i = 10;
};
/* Notice how local modules names may be used twice and are shadowed */
module MyLocalModule: MySecondModuleType = {
type someType = int;
let x:someType = 10;
let y:someType = 20;
};
let tmp = MyLocalModule.x + 22;
tmp + 30;
};
module type HasTT = {
type tt;
};
module SubModule: HasTT = {
type tt = int;
};
module type HasEmbeddedHasTT = {
module SubModuleThatHasTT = SubModule;
};
module type HasPolyType = {type t('a);};
module type HasDestructivelySubstitutedPolyType =
HasPolyType with type t('a) := list('a);
module type HasDestructivelySubstitutedSubPolyModule = {
/* Cannot perform destructive substitution on submodules! */
/* module X: HasPolyType with type t := list (int, int); */
module X: HasDestructivelySubstitutedPolyType;
};
module type HasSubPolyModule = {
/* Cannot perform destructive substitution on submodules! */
/* module X: HasPolyType with type t := list (int, int); */
module X: HasPolyType;
};
module EmbedsSubPolyModule: HasSubPolyModule = {
module X = {
type t('a) = list('a);
};
};
module EmbedsDestructivelySubstitutedPolyModule: HasDestructivelySubstitutedSubPolyModule = {
module X = {
type t = list (int, int);
};
};
module type HasMultiPolyType = {
type substituteThis('a,'b);
type substituteThat('a,'b);
};
module type HasDestructivelySubstitutedMultiPolyType = (
HasMultiPolyType with
type substituteThis('a,'b) := Hashtbl.t('a,'b) and
type substituteThat('a,'b) := Hashtbl.t('a,'b)
);
module InliningSig: {let x: int; let y:int;} = {
/*
* Comment inside of signature.
*/
let x = 10;
/* Inline comment inside signature. */
let y = 20;
};
module MyFunctor = fun (M: HasTT) => {
type reexportedTT = M.tt;
/* Inline comment inside module. */
/** Following special comment inside module. */
let someValue = 1000;
};
/* Notice how
- Functors no longer require parens around argument.
- A final semicolon is required for module structures.
- We should eliminate both those requirements. See action items 13-14 at the
bottom of this file. [Actually, forgiving the trailing SEMI might not be
such a great idea].
*/
module MyFunctorResult = MyFunctor ({type tt = string;});
module LookNoParensNeeded = MyFunctor {type tt = string;};
module type SigResult = {let result:int;};
module type ASig = {let a:int;};
module type BSig = {let b:int;};
module AMod = {let a = 10;};
module BMod = {let b = 10;};
module CurriedSugar (A:ASig, B:BSig) {
let result = A.a + B.b;
};
/* Right now [CurriedSuperSugar] is parsed as being indistinguishable from
the above.
module CurriedSuperSugar (A:ASig) (B:BSig): SigResult => ({
let result = A.a + B.b;
}: SigResult);
/* Not supported in OCaml OR Reason (Edit: now supported in OCaml for functions) */
let x = fun (a:foo) :bar => baz;
module x = fun (A:Foo) :Bar => Baz;
/* Supported in both OCaml and Reason */
let x (a:foo) :bar => baz;
module x (A:Foo) :Bar => Baz;
*/
module CurriedSugarWithReturnType (A:ASig, B:BSig): SigResult {
let result = A.a + B.b;
};
/* This is parsed as being equivalent to the above example */
module CurriedSugarWithAnnotatedReturnVal (A:ASig, B:BSig) = ({
let result = A.a + B.b;
}: SigResult);
module CurriedNoSugar = fun (A:ASig) => fun (B:BSig) => {
let result = A.a + B.b;
};
let letsTryThatSyntaxInLocalModuleBindings () {
module CurriedSugarWithReturnType (A:ASig, B:BSig): SigResult = {
let result = A.a + B.b;
};
module CurriedSugarWithAnnotatedReturnVal (A:ASig, B:BSig) = ({
let result = A.a + B.b;
}: SigResult);
module CurriedNoSugar = fun (A:ASig) => fun (B:BSig) => {
let result = A.a + B.b;
};
/*
* The following doesn't work in OCaml (LocalModule (struct end)).x isn't even
* parsed!
*
* let thisDoesntWorkInOCaml () =
* module LocalModule(A:sig end) = struct let x = 10 end in
* module Out = (LocalModule (struct end)) in
* let outVal = (LocalModule (struct end)).x in
* let res = Out.x in
* res;;
*/
module TempModule = CurriedNoSugar(AMod,BMod);
module TempModule2 = CurriedSugarWithAnnotatedReturnVal(AMod,BMod);
TempModule.result + TempModule2.result;
};
module type EmptySig = {};
module MakeAModule (X:EmptySig) {let a = 10;};
module CurriedSugarFunctorResult = CurriedSugar(AMod,BMod);
module CurriedSugarFunctorResultInline = CurriedSugar {let a=10;} {let b=10;};
module CurriedNoSugarFunctorResult = CurriedNoSugar(AMod,BMod);
module CurriedNoSugarFunctorResultInline = CurriedNoSugar {let a=10;} {let b=10;};
module ResultFromNonSimpleFunctorArg = CurriedNoSugar (MakeAModule {}, BMod);
/* TODO: Functor type signatures should more resemble value signatures */
let curriedFunc: (int,int)=>int = fun(a,b) => a + b;
module type FunctorType = (ASig) => (BSig) => SigResult;
/* Which is sugar for:*/
module type FunctorType2 = (_:ASig) => (_:BSig) => SigResult;
/* Just for compability with existing OCaml ASTs you can put something other
* than an underscore */
module type FunctorType3 = (Blah:ASig) => (ThisIsIgnored:BSig) => SigResult;
/* The actual functors themselves now have curried sugar (which the pretty
* printer will enforce as well */
/* The following: */
module CurriedSugarWithAnnotation2: (ASig) => (BSig) => SigResult =
fun (A:ASig) => fun (B:BSig) => {let result = A.a + B.b;};
/* Becomes: */
module CurriedSugarWithAnnotation: (ASig) => (BSig) => SigResult =
fun (A:ASig, B:BSig) => {let result = A.a + B.b;};
/* "functors" that are not in sugar curried form cannot annotate a return type
* for now, so we settle for: */
module CurriedSugarWithAnnotationAndReturnAnnotated: (ASig, BSig) => SigResult =
(A:ASig, B:BSig) => ({let result = A.a + B.b;}: SigResult);
module ReturnsAFunctor (A:ASig, B:BSig): (ASig, BSig) => SigResult =
(A:ASig, B:BSig) => {
let result = 10;
};
module ReturnsSigResult (A:ASig, B:BSig): SigResult {
let result = 10;
};
module ReturnsAFunctor2 (A:ASig, B:BSig): (ASig, BSig) => SigResult =
(A:ASig, B:BSig) => {let result = 10;};
/*
* Recursive modules.
* TODO: Test [Psig_recmodule]
*/
module rec A : {
type t = Leaf(string) | Node(ASet.t);
let compare: (t, t) => int;
} = {
type t = Leaf(string) | Node(ASet.t);
let compare(t1,t2) = switch (t1, t2) {
| (Leaf(s1), Leaf(s2)) => Pervasives.compare(s1, s2)
| (Leaf(_), Node(_)) => 1
| (Node(_), Leaf(_)) => -1
| (Node(n1), Node(n2)) => ASet.compare(n1, n2)
};
}
and ASet: Set.S with type elt = A.t = Set.Make(A);
/*
* How recursive modules appear in signatures.
*/
module type HasRecursiveModules = {
module rec A: {
type t = | Leaf(string) | Node(ASet.t);
let compare: (t, t) => int;
}
and ASet: Set.S with type elt = A.t;
};
/* From http://stackoverflow.com/questions/1986374/higher-order-type-constructors-and-functors-in-ocaml */
module type Type {type t;};
module Char {type t = char;};
module List (X:Type) {type t = list(X.t);};
module Maybe (X:Type) {type t = option(X.t);};
module Id (X:Type) = X;
module Compose (F:(Type)=>Type, G:(Type)=>Type, X:Type) = F(G(X));
let l : Compose(List,Maybe,Char).t = [Some('a')];
module Example2 (F:(Type)=>Type, X:Type) {
/**
* Note: This is the one remaining syntactic issue where
* modules/functions do not have syntax unified with values.
* It should be:
*
* let iso (a:(Compose Id F X).t): (F X).t => a;
*
*/
let iso (a:Compose(Id,F,X).t): F(X).t = a;
};
Printf.printf("\nModules And Functors: %n\n", CurriedNoSugarFunctorResultInline.result);
/* We would have: */
/* module CurriedSugarWithAnnotation: ASig => BSig => SigResult =
fun (A:ASig) (B:BSig) => {let result = A.a + B.b;; */
/*
module Typeahead = React.Create {
type props = {initialCount: int};
type state = {count: int};
let getInitialState props => {count: 10};
let render {props, state} =>
<div>
<span><BigBox></span>
</div>;
};
*/
include YourLib.CreateComponent {
type thing = blahblahblah;
type state = unit;
let getInitialState(_)= ();
let myValue = {
recordField: "hello"
};
};
module type HasInt = {let x: int;};
module MyModule = {let x = 10;};
let myFirstClass = (module MyModule : HasInt);
let myFirstClassWillBeFormattedAs: (module HasInt) = (module MyModule);
let acceptsAndUnpacksFirstClass ((module M : HasInt)) = M.x + M.x;
let acceptsAndUnpacksFirstClass ((module M) : (module HasInt)) = M.x + M.x;
module SecondClass = (val myFirstClass);
module SecondClass2 = (val (module MyModule: HasInt));
let p = SecondClass.x;
/* Opening Modules */
module M = {
module Inner = {};
};
module N = {
open M;
let z = { open M; 34; };
let z = { open M; 34; 35; };
let z = { open M; (34, 35) };
let z = M.(34, 35);
let z = M.((34, 35));
let z = { open M; {} };
let z = M.{};
let z = M.({});
let z = { open M; {x:10} };
let z = { open M; [foo, bar] };
let z = { open M; ([foo, bar]) };
let z = { open M; ({x: 10, y:20}) };
let z = { open M; let open M2; value };
let z = { open M; M2.value };
let z = { open! M; 34; };
let z = { open! M; 34; 35; };
let z = { open! M; {} };
let z = { open! M; {x:10} };
let z = { open! M; [foo, bar] };
let z = { open! M; ([foo, bar]) };
let z = { open! M; ({x: 10, y:20}) };
let z = { open! M; let open! M2; value };
let z = { open! M; M2.value };
let y = 44;
};
open M;
open M.Inner;
open M;
let module OldModuleSyntax = {
let module InnerOldModule = {
};
};
module type SigWithModuleTypeOf = {
module type ModuleType;
include (module type of String);
include (module type of Array);
};
module type T = t with type t = (a) => a;
module type T = t with type t = ((a) => a);
module type T = (t with type t = a) => a;
module X = [%test extension];
module type T = [%test extension];
let foo (type a, (module X): (module X_t with type t =a)) = X.a;
let f = ((module M): (module M with type x = x and type y = y)) => M.x;
let foo =
(
(module X): (module X_t with type t = a and type s = a and type z = a),
(module Y): (module Y_t with type t = a),
(module Z): (module Z_t with type t = a),
) => X.a;
/* https://github.com/facebook/reason/issues/2028 */
M.[];
module type Event = (module type of {
include ReactEventRe;
});
include (Version2: (module type of Version2));
/* https://github.com/facebook/reason/issues/2608 */
module Functor = (): (module type of {}) => {};
module Lola1 = () => {
let a = 3;
}
module Lola2 = (C: Cat, D: Dog, L: Lion) => {
let a = 33;
}
module L = Lola1();
module L2 = Lola2(Cat, Dog, Foo);
let y = Promise.Ops.(
open Foo.Bar;
let a = 2
Bar.(
let* x = Js.Promise.resolve(42);
let a = 1;
Js.Promise.resolve(x * 2)
)
);
module WithExternalExtension: {
external%foo bar: string => string = "";
[%%foo: external bar: int => int = "hello" ];
} = {
external%foo bar: string => string = "";
[%%foo external bar: int => int = "hello" ];
}
module type TypeWithExternalExtension = {
external%foo bar: string => string = "";
[%%foo: external bar: int => int = "hello" ];
}
module%foo X = Y
module%foo X = {
let x = 1;
};
let x = {
let module%foo X = {
let x = 1;
};
()
};
module%foo rec X: Y = {
let x = 1;
}
let f = () => {
open {
let x = 1;
};
();
};
let f = () => {
let open {
let x = 1;
};
();
};
open {
let x = 1;
};
module X : {
module Z := Y;
module type Foo := y;
} = {};
module type t' = t with module type x = x
module type t3 = t with module type x = { type t }
module type t' = t with module type x := x
module type t4 = t with module type x := { type t }
module Foo =
[@someattr]
{
type t = string
};
let x = {
let module Foo =
[@someattr] {
type t = string
};
()
};
================================================
FILE: test/modules.t/run.t
================================================
Format modules
$ refmt ./input.re
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
let run = () => {
TestUtils.printSection("Modules");
};
/**
* Modules:
* ----------------------------------------------------------------------------
* Modules accomplish the following:
* - Organization of code and data.
* - Basis for separate compilation and fast compile times.
* - Enabled higher order type abstractions that are capable of modelling very
* sophisticated typing relationships between various parts of your code.
*
* Modules are much like records, but much more powerful. Much of modules'
* powers are derived from the fact that they are primarily built up and
* organized at compilation time, instead of runtime. It is this constraint
* that allows modules to be more powerful than simple records.
*
* There are some important ways that modules differ from records:
*
* - Fields are lexically scoped: In the following record: `{x:1, y: x + x}`,
* the reference to `x` does not refer to the record field `x`. This is because
* records fields do not form lexical scopes for the evaluation of other record
* values. Modules, on the other hand do allow fields to reference other
* fields. Appropriately, each field is introduced via the keyword `let`.
*/
module MyFirstModule = {
let x = 0;
let y = x + x;
};
let result = MyFirstModule.x + MyFirstModule.y;
/**
* - A module is introduced with the `module` phrase.
* - A module *must* have a capital letter as its first character.
* - The exported fields of a module must be listed within `{}` braces and each
* exported value binding is specified via a `let` keyword.
*/
/**
* Another way that modules are more powerful than records, is that they may
* also export types.
*/
module MySecondModule = {
type someType = int;
let x = 0;
let y = x + x;
};
let myInt: MySecondModule.someType = 100;
/** Module signatures:
* ----------------------------------------------------------------------------
* Not only may modules export types, but modules *themselves* can be described
* by types via the `module type` phrase. We call these module types
* "signatures". For example, `MySecondModule` has the following `module type`
* signature:
*/
module type MySecondModuleType = {
type someType = int;
let x: int;
let y: int;
};
/**
* Much like how you can ensure that a value is compatible with a specific
* type:
let myTestVal: int = 10;
* You can also perform the same type of annotation to ensure that you have
* written code that matches your understanding. For example, `MySecondModule`
* could have been written as:
module MySecondModule: MySecondModuleType = {
type someType = int;
let x = 0;
let y = x + x;
};
*/
/**
* - Modules may be artificially "constrained" so that users of a module see
* fewer details than are actually present.
* - Modules may be combined, merged, and transformed at compile time in ways
* that
* - Because they are more powerful, they may not be passed around at runtime
* as easily as records.
*
* Some additioal benefits to using modules:
* - Modules are a very elegant way to organize large packages of code.
* - Modules are the unit of compilation. Minimal recompilation changes
* - Modules can help you achieve higher degrees of polymorphism than the core
* language.
*/
let opensAModuleLocally = {
module MyLocalModule = {
type i = int;
let x: i = 10;
};
/* Notice how local modules names may be used twice and are shadowed */
module MyLocalModule: MySecondModuleType = {
type someType = int;
let x: someType = 10;
let y: someType = 20;
};
let tmp = MyLocalModule.x + 22;
tmp + 30;
};
module type HasTT = {
type tt;
};
module SubModule: HasTT = {
type tt = int;
};
module type HasEmbeddedHasTT = {
module SubModuleThatHasTT = SubModule;
};
module type HasPolyType = {
type t('a);
};
module type HasDestructivelySubstitutedPolyType =
HasPolyType with type t('a) := list('a);
module type HasDestructivelySubstitutedSubPolyModule = {
/* Cannot perform destructive substitution on submodules! */
/* module X: HasPolyType with type t := list (int, int); */
module X: HasDestructivelySubstitutedPolyType;
};
module type HasSubPolyModule = {
/* Cannot perform destructive substitution on submodules! */
/* module X: HasPolyType with type t := list (int, int); */
module X: HasPolyType;
};
module EmbedsSubPolyModule: HasSubPolyModule = {
module X = {
type t('a) = list('a);
};
};
module EmbedsDestructivelySubstitutedPolyModule:
HasDestructivelySubstitutedSubPolyModule = {
module X = {
type t = list(int, int);
};
};
module type HasMultiPolyType = {
type substituteThis('a, 'b);
type substituteThat('a, 'b);
};
module type HasDestructivelySubstitutedMultiPolyType =
HasMultiPolyType with
type substituteThis('a, 'b) :=
Hashtbl.t('a, 'b) and
type substituteThat('a, 'b) :=
Hashtbl.t('a, 'b);
module InliningSig: {
let x: int;
let y: int;
} = {
/*
* Comment inside of signature.
*/
let x = 10;
/* Inline comment inside signature. */
let y = 20;
};
module MyFunctor = (M: HasTT) => {
type reexportedTT = M.tt;
/* Inline comment inside module. */
/** Following special comment inside module. */
let someValue = 1000;
};
/* Notice how
- Functors no longer require parens around argument.
- A final semicolon is required for module structures.
- We should eliminate both those requirements. See action items 13-14 at the
bottom of this file. [Actually, forgiving the trailing SEMI might not be
such a great idea].
*/
module MyFunctorResult =
MyFunctor({
type tt = string;
});
module LookNoParensNeeded =
MyFunctor({
type tt = string;
});
module type SigResult = {
let result: int;
};
module type ASig = {
let a: int;
};
module type BSig = {
let b: int;
};
module AMod = {
let a = 10;
};
module BMod = {
let b = 10;
};
module CurriedSugar = (A: ASig, B: BSig) => {
let result = A.a + B.b;
};
/* Right now [CurriedSuperSugar] is parsed as being indistinguishable from
the above.
module CurriedSuperSugar (A:ASig) (B:BSig): SigResult => ({
let result = A.a + B.b;
}: SigResult);
/* Not supported in OCaml OR Reason (Edit: now supported in OCaml for functions) */
let x = fun (a:foo) :bar => baz;
module x = fun (A:Foo) :Bar => Baz;
/* Supported in both OCaml and Reason */
let x (a:foo) :bar => baz;
module x (A:Foo) :Bar => Baz;
*/
module CurriedSugarWithReturnType =
(A: ASig, B: BSig)
: SigResult => {
let result = A.a + B.b;
};
/* This is parsed as being equivalent to the above example */
module CurriedSugarWithAnnotatedReturnVal =
(A: ASig, B: BSig)
: SigResult => {
let result = A.a + B.b;
};
module CurriedNoSugar = (A: ASig, B: BSig) => {
let result = A.a + B.b;
};
let letsTryThatSyntaxInLocalModuleBindings = () => {
module CurriedSugarWithReturnType =
(A: ASig, B: BSig)
: SigResult => {
let result = A.a + B.b;
};
module CurriedSugarWithAnnotatedReturnVal =
(A: ASig, B: BSig)
: SigResult => {
let result = A.a + B.b;
};
module CurriedNoSugar = (A: ASig, B: BSig) => {
let result = A.a + B.b;
};
/*
* The following doesn't work in OCaml (LocalModule (struct end)).x isn't even
* parsed!
*
* let thisDoesntWorkInOCaml () =
* module LocalModule(A:sig end) = struct let x = 10 end in
* module Out = (LocalModule (struct end)) in
* let outVal = (LocalModule (struct end)).x in
* let res = Out.x in
* res;;
*/
module TempModule =
CurriedNoSugar(AMod, BMod);
module TempModule2 =
CurriedSugarWithAnnotatedReturnVal(
AMod,
BMod,
);
TempModule.result + TempModule2.result;
};
module type EmptySig = {};
module MakeAModule = (X: EmptySig) => {
let a = 10;
};
module CurriedSugarFunctorResult =
CurriedSugar(AMod, BMod);
module CurriedSugarFunctorResultInline =
CurriedSugar(
{
let a = 10;
},
{
let b = 10;
},
);
module CurriedNoSugarFunctorResult =
CurriedNoSugar(AMod, BMod);
module CurriedNoSugarFunctorResultInline =
CurriedNoSugar(
{
let a = 10;
},
{
let b = 10;
},
);
module ResultFromNonSimpleFunctorArg =
CurriedNoSugar(MakeAModule(), BMod);
/* TODO: Functor type signatures should more resemble value signatures */
let curriedFunc: (int, int) => int = (a, b) =>
a + b;
module type FunctorType =
(ASig, BSig) => SigResult;
/* Which is sugar for:*/
module type FunctorType2 =
(ASig, BSig) => SigResult;
/* Just for compability with existing OCaml ASTs you can put something other
* than an underscore */
module type FunctorType3 =
(Blah: ASig, ThisIsIgnored: BSig) => SigResult;
/* The actual functors themselves now have curried sugar (which the pretty
* printer will enforce as well */
/* The following: */
module CurriedSugarWithAnnotation2:
(ASig, BSig) => SigResult =
(A: ASig, B: BSig) => {
let result = A.a + B.b;
};
/* Becomes: */
module CurriedSugarWithAnnotation:
(ASig, BSig) => SigResult =
(A: ASig, B: BSig) => {
let result = A.a + B.b;
};
/* "functors" that are not in sugar curried form cannot annotate a return type
* for now, so we settle for: */
module CurriedSugarWithAnnotationAndReturnAnnotated:
(ASig, BSig) => SigResult =
(A: ASig, B: BSig) => (
{
let result = A.a + B.b;
}:
SigResult
);
module ReturnsAFunctor =
(A: ASig, B: BSig)
: ((ASig, BSig) => SigResult) =>
(A: ASig, B: BSig) => {
let result = 10;
};
module ReturnsSigResult =
(A: ASig, B: BSig)
: SigResult => {
let result = 10;
};
module ReturnsAFunctor2 =
(A: ASig, B: BSig)
: ((ASig, BSig) => SigResult) =>
(A: ASig, B: BSig) => {
let result = 10;
};
/*
* Recursive modules.
* TODO: Test [Psig_recmodule]
*/
module rec A: {
type t =
| Leaf(string)
| Node(ASet.t);
let compare: (t, t) => int;
} = {
type t =
| Leaf(string)
| Node(ASet.t);
let compare = (t1, t2) =>
switch (t1, t2) {
| (Leaf(s1), Leaf(s2)) =>
Pervasives.compare(s1, s2)
| (Leaf(_), Node(_)) => 1
| (Node(_), Leaf(_)) => (-1)
| (Node(n1), Node(n2)) =>
ASet.compare(n1, n2)
};
}
and ASet: Set.S with type elt = A.t =
Set.Make(A);
/*
* How recursive modules appear in signatures.
*/
module type HasRecursiveModules = {
module rec A: {
type t =
| Leaf(string)
| Node(ASet.t);
let compare: (t, t) => int;
}
and ASet: Set.S with type elt = A.t;
};
/* From http://stackoverflow.com/questions/1986374/higher-order-type-constructors-and-functors-in-ocaml */
module type Type = {
type t;
};
module Char = {
type t = char;
};
module List = (X: Type) => {
type t = list(X.t);
};
module Maybe = (X: Type) => {
type t = option(X.t);
};
module Id = (X: Type) => X;
module Compose =
(
F: (Type) => Type,
G: (Type) => Type,
X: Type,
) =>
F(G(X));
let l: Compose(List)(Maybe)(Char).t = [
Some('a'),
];
module Example2 = (F: (Type) => Type, X: Type) => {
/**
* Note: This is the one remaining syntactic issue where
* modules/functions do not have syntax unified with values.
* It should be:
*
* let iso (a:(Compose Id F X).t): (F X).t => a;
*
*/
let iso = (a: Compose(Id)(F)(X).t): F(X).t => a;
};
Printf.printf(
"\nModules And Functors: %n\n",
CurriedNoSugarFunctorResultInline.result,
);
/* We would have: */
/* module CurriedSugarWithAnnotation: ASig => BSig => SigResult =
fun (A:ASig) (B:BSig) => {let result = A.a + B.b;; */
/*
module Typeahead = React.Create {
type props = {initialCount: int};
type state = {count: int};
let getInitialState props => {count: 10};
let render {props, state} =>
<div>
<span><BigBox></span>
</div>;
};
*/
include YourLib.CreateComponent({
type thing = blahblahblah;
type state = unit;
let getInitialState = _ => ();
let myValue = { recordField: "hello" };
});
module type HasInt = {
let x: int;
};
module MyModule = {
let x = 10;
};
let myFirstClass: module HasInt =
(module MyModule);
let myFirstClassWillBeFormattedAs: (module HasInt) =
(module MyModule);
let acceptsAndUnpacksFirstClass =
(module M: HasInt) =>
M.x + M.x;
let acceptsAndUnpacksFirstClass =
(module M: HasInt) =>
M.x + M.x;
module SecondClass = (val myFirstClass);
module SecondClass2 = (
val (module MyModule): HasInt
);
let p = SecondClass.x;
/* Opening Modules */
module M = {
module Inner = {};
};
module N = {
open M;
let z = {
M.(34);
};
let z = {
open M;
34;
35;
};
let z = {
M.(34, 35);
};
let z = M.(34, 35);
let z = M.(34, 35);
let z = {
M.{};
};
let z = M.{};
let z = M.{};
let z = {
M.{ x: 10 };
};
let z = {
M.[foo, bar];
};
let z = {
M.[foo, bar];
};
let z = {
M.{
x: 10,
y: 20,
};
};
let z = {
M.(M2.(value));
};
let z = {
M.(M2.value);
};
let z = {
open! M;
34;
};
let z = {
open! M;
34;
35;
};
let z = {
open! M;
{};
};
let z = {
open! M;
{ x: 10 };
};
let z = {
open! M;
[foo, bar];
};
let z = {
open! M;
[foo, bar];
};
let z = {
open! M;
{
x: 10,
y: 20,
};
};
let z = {
open! M;
open! M2;
value;
};
let z = {
open! M;
M2.value;
};
let y = 44;
};
open M;
open M.Inner;
open M;
module OldModuleSyntax = {
module InnerOldModule = {};
};
module type SigWithModuleTypeOf = {
module type ModuleType;
include (module type of String);
include (module type of Array);
};
module type T = t with type t = a => a;
module type T = t with type t = a => a;
module type T = (t with type t = a) => a;
module X = [%test extension];
module type T = [%test extension];
let foo =
(type a, module X: X_t with type t = a) => X.a;
let f =
(module M: M with type x = x and type y = y) => M.x;
let foo =
(
module X:
X_t with
type t = a and
type s = a and
type z = a,
module Y: Y_t with type t = a,
module Z: Z_t with type t = a,
) => X.a;
/* https://github.com/facebook/reason/issues/2028 */
M.[];
module type Event = (module type of {
include ReactEventRe;
});
include (Version2: (module type of Version2));
/* https://github.com/facebook/reason/issues/2608 */
module Functor = () : (module type of {}) => {};
module Lola1 = () => {
let a = 3;
};
module Lola2 = (C: Cat, D: Dog, L: Lion) => {
let a = 33;
};
module L = Lola1();
module L2 = Lola2(Cat, Dog, Foo);
let y =
Promise.Ops.(
open Foo.Bar;
let a = 2;
Bar.(
let* x = Js.Promise.resolve(42);
let a = 1;
Js.Promise.resolve(x * 2);
)
);
module WithExternalExtension: {
external%foo bar: string => string;
external%foo bar: int => int = "hello";
} = {
external%foo bar: string => string;
external%foo bar: int => int = "hello";
};
module type TypeWithExternalExtension = {
external%foo bar: string => string;
external%foo bar: int => int = "hello";
};
module%foo X = Y;
module%foo X = {
let x = 1;
};
let x = {
module%foo X = {
let x = 1;
};
();
};
module%foo rec X: Y = {
let x = 1;
};
let f = () => {
open {
let x = 1;
};
();
};
let f = () => {
open {
let x = 1;
};
();
};
open {
let x = 1;
};
module X: {
module Z := Y;
module type Foo := y;
} = {};
module type t' = t with module type x = x;
module type t3 =
t with module type x = {
type t;
};
module type t' = t with module type x := x;
module type t4 =
t with module type x := {
type t;
};
module Foo =
[@someattr]
{
type t = string;
};
let x = {
module Foo =
[@someattr]
{
type t = string;
};
();
};
/* From http://stackoverflow.com/questions/1986374/ higher-order-type-constructors-and-functors-in-ocaml */
================================================
FILE: test/modules_no_semi.t/input.re
================================================
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
let run = fun () => {
TestUtils.printSection("Modules")
};
/**
* Modules:
* ----------------------------------------------------------------------------
* Modules accomplish the following:
* - Organization of code and data.
* - Basis for separate compilation and fast compile times.
* - Enabled higher order type abstractions that are capable of modelling very
* sophisticated typing relationships between various parts of your code.
*
* Modules are much like records, but much more powerful. Much of modules'
* powers are derived from the fact that they are primarily built up and
* organized at compilation time, instead of runtime. It is this constraint
* that allows modules to be more powerful than simple records.
*
* There are some important ways that modules differ from records:
*
* - Fields are lexically scoped: In the following record: `{x:1, y: x + x}`,
* the reference to `x` does not refer to the record field `x`. This is because
* records fields do not form lexical scopes for the evaluation of other record
* values. Modules, on the other hand do allow fields to reference other
* fields. Appropriately, each field is introduced via the keyword `let`.
*/
module MyFirstModule = {
let x = 0
let y = x + x
}
let result = MyFirstModule.x + MyFirstModule.y;
/**
* - A module is introduced with the `module` phrase.
* - A module *must* have a capital letter as its first character.
* - The exported fields of a module must be listed within `{}` braces and each
* exported value binding is specified via a `let` keyword.
*/
/**
* Another way that modules are more powerful than records, is that they may
* also export types.
*/
module MySecondModule = {
type someType = int
let x = 0
let y = x + x
}
let myInt:MySecondModule.someType = 100;
/** Module signatures:
* ----------------------------------------------------------------------------
* Not only may modules export types, but modules *themselves* can be described
* by types via the `module type` phrase. We call these module types
* "signatures". For example, `MySecondModule` has the following `module type`
* signature:
*/
module type MySecondModuleType = {
type someType = int
let x: int
let y: int
}
/**
* Much like how you can ensure that a value is compatible with a specific
* type:
let myTestVal: int = 10
* You can also perform the same type of annotation to ensure that you have
* written code that matches your understanding. For example, `MySecondModule`
* could have been written as:
module MySecondModule: MySecondModuleType = {
type someType = int
let x = 0
let y = x + x
}
*/
/**
* - Modules may be artificially "constrained" so that users of a module see
* fewer details than are actually present.
* - Modules may be combined, merged, and transformed at compile time in ways
* that
* - Because they are more powerful, they may not be passed around at runtime
* as easily as records.
*
* Some additioal benefits to using modules:
* - Modules are a very elegant way to organize large packages of code.
* - Modules are the unit of compilation. Minimal recompilation changes
* - Modules can help you achieve higher degrees of polymorphism than the core
* language.
*/
let opensAModuleLocally = {
module MyLocalModule = {
type i = int
let x:i = 10
}
/* Notice how local modules names may be used twice and are shadowed */
module MyLocalModule: MySecondModuleType = {
type someType = int
let x:someType = 10
let y:someType = 20
}
let tmp = MyLocalModule.x + 22;
tmp + 30
}
module type HasTT = {
type tt
}
module SubModule: HasTT = {
type tt = int
}
module type HasEmbeddedHasTT = {
module SubModuleThatHasTT = SubModule
}
module type HasPolyType = {type t('a)}
module type HasDestructivelySubstitutedPolyType =
HasPolyType with type t('a) := list('a)
module type HasDestructivelySubstitutedSubPolyModule = {
/* Cannot perform destructive substitution on submodules! */
/* module X: HasPolyType with type t := list (int, int) */
module X: HasDestructivelySubstitutedPolyType
}
module type HasSubPolyModule = {
/* Cannot perform destructive substitution on submodules! */
/* module X: HasPolyType with type t := list (int, int) */
module X: HasPolyType
}
module EmbedsSubPolyModule: HasSubPolyModule = {
module X = {
type t('a) = list('a)
}
}
module EmbedsDestructivelySubstitutedPolyModule: HasDestructivelySubstitutedSubPolyModule = {
module X = {
type t = list (int, int)
}
}
module type HasMultiPolyType = {
type substituteThis('a,'b)
type substituteThat('a,'b)
}
module type HasDestructivelySubstitutedMultiPolyType = (
HasMultiPolyType with
type substituteThis('a,'b) := Hashtbl.t('a,'b) and
type substituteThat('a,'b) := Hashtbl.t('a,'b)
)
module InliningSig: {let x: int let y:int} = {
/*
* Comment inside of signature.
*/
let x = 10
/* Inline comment inside signature. */
let y = 20
}
module MyFunctor = fun (M: HasTT) => {
type reexportedTT = M.tt;
/* Inline comment inside module. */
/** Following special comment inside module. */
let someValue = 1000
}
/* Notice how
- Functors no longer require parens around argument.
- A final semicolon is required for module structures.
- We should eliminate both those requirements. See action items 13-14 at the
bottom of this file. [Actually, forgiving the trailing SEMI might not be
such a great idea].
*/
module MyFunctorResult = MyFunctor ({type tt = string})
module LookNoParensNeeded = MyFunctor {type tt = string}
module type SigResult = {let result:int}
module type ASig = {let a:int}
module type BSig = {let b:int}
module AMod = {let a = 10}
module BMod = {let b = 10}
module CurriedSugar (A:ASig, B:BSig) {
let result = A.a + B.b
}
/* Right now [CurriedSuperSugar] is parsed as being indistinguishable from
the above.
module CurriedSuperSugar (A:ASig) (B:BSig): SigResult => ({
let result = A.a + B.b
}: SigResult)
/* Not supported in OCaml OR Reason (Edit: now supported in OCaml for functions) */
let x = fun (a:foo) :bar => baz
module x = fun (A:Foo) :Bar => Baz
/* Supported in both OCaml and Reason */
let x (a:foo) :bar => baz
module x (A:Foo) :Bar => Baz
*/
module CurriedSugarWithReturnType (A:ASig, B:BSig): SigResult {
let result = A.a + B.b
}
/* This is parsed as being equivalent to the above example */
module CurriedSugarWithAnnotatedReturnVal (A:ASig, B:BSig) = ({
let result = A.a + B.b
}: SigResult)
module CurriedNoSugar = fun (A:ASig) => fun (B:BSig) => {
let result = A.a + B.b
}
let letsTryThatSyntaxInLocalModuleBindings () {
module CurriedSugarWithReturnType (A:ASig, B:BSig): SigResult = {
let result = A.a + B.b
}
module CurriedSugarWithAnnotatedReturnVal (A:ASig, B:BSig) = ({
let result = A.a + B.b
}: SigResult)
module CurriedNoSugar = fun (A:ASig) => fun (B:BSig) => {
let result = A.a + B.b
}
/*
* The following doesn't work in OCaml (LocalModule (struct end)).x isn't even
* parsed!
*
* let thisDoesntWorkInOCaml () =
* module LocalModule(A:sig end) = struct let x = 10 end in
* module Out = (LocalModule (struct end)) in
* let outVal = (LocalModule (struct end)).x in
* let res = Out.x in
* res
*/
module TempModule = CurriedNoSugar(AMod,BMod)
module TempModule2 = CurriedSugarWithAnnotatedReturnVal(AMod,BMod);
TempModule.result + TempModule2.result
}
module type EmptySig = {}
module MakeAModule (X:EmptySig) {let a = 10}
module CurriedSugarFunctorResult = CurriedSugar(AMod,BMod)
module CurriedSugarFunctorResultInline = CurriedSugar {let a=10} {let b=10}
module CurriedNoSugarFunctorResult = CurriedNoSugar(AMod,BMod)
module CurriedNoSugarFunctorResultInline = CurriedNoSugar {let a=10} {let b=10}
module ResultFromNonSimpleFunctorArg = CurriedNoSugar (MakeAModule {}, BMod)
/* TODO: Functor type signatures should more resemble value signatures */
let curriedFunc: (int,int)=>int = fun(a,b) => a + b
module type FunctorType = (ASig) => (BSig) => SigResult
/* Which is sugar for:*/
module type FunctorType2 = (_:ASig) => (_:BSig) => SigResult
/* Just for compability with existing OCaml ASTs you can put something other
* than an underscore */
module type FunctorType3 = (Blah:ASig) => (ThisIsIgnored:BSig) => SigResult
/* The actual functors themselves now have curried sugar (which the pretty
* printer will enforce as well */
/* The following: */
module CurriedSugarWithAnnotation2: (ASig) => (BSig) => SigResult =
fun (A:ASig) => fun (B:BSig) => {let result = A.a + B.b}
/* Becomes: */
module CurriedSugarWithAnnotation: (ASig) => (BSig) => SigResult =
fun (A:ASig, B:BSig) => {let result = A.a + B.b}
/* "functors" that are not in sugar curried form cannot annotate a return type
* for now, so we settle for: */
module CurriedSugarWithAnnotationAndReturnAnnotated: (ASig, BSig) => SigResult =
(A:ASig, B:BSig) => ({let result = A.a + B.b}: SigResult)
module ReturnsAFunctor (A:ASig, B:BSig): (ASig, BSig) => SigResult =
(A:ASig, B:BSig) => {
let result = 10
}
module ReturnsSigResult (A:ASig, B:BSig): SigResult {
let result = 10
}
module ReturnsAFunctor2 (A:ASig, B:BSig): (ASig, BSig) => SigResult =
(A:ASig, B:BSig) => {let result = 10}
/*
* Recursive modules.
* TODO: Test [Psig_recmodule]
*/
module rec A : {
type t = Leaf(string) | Node(ASet.t)
let compare: (t, t) => int
} = {
type t = Leaf(string) | Node(ASet.t)
let compare(t1,t2) = switch (t1, t2) {
| (Leaf(s1), Leaf(s2)) => Pervasives.compare(s1, s2)
| (Leaf(_), Node(_)) => 1
| (Node(_), Leaf(_)) => -1
| (Node(n1), Node(n2)) => ASet.compare(n1, n2)
}
}
and ASet: Set.S with type elt = A.t = Set.Make(A)
/*
* How recursive modules appear in signatures.
*/
module type HasRecursiveModules = {
module rec A: {
type t = | Leaf(string) | Node(ASet.t)
let compare: (t, t) => int
}
and ASet: Set.S with type elt = A.t
}
/* From http://stackoverflow.com/questions/1986374/higher-order-type-constructors-and-functors-in-ocaml */
module type Type {type t}
module Char {type t = char}
module List (X:Type) {type t = list(X.t)}
module Maybe (X:Type) {type t = option(X.t)}
module Id (X:Type) = X
module Compose (F:(Type)=>Type, G:(Type)=>Type, X:Type) = F(G(X))
let l : Compose(List,Maybe,Char).t = [Some('a')]
module Example2 (F:(Type)=>Type, X:Type) {
/**
* Note: This is the one remaining syntactic issue where
* modules/functions do not have syntax unified with values.
* It should be:
*
* let iso (a:(Compose Id F X).t): (F X).t => a
*
*/
let iso (a:Compose(Id,F,X).t): F(X).t = a
};
Printf.printf("\nModules And Functors: %n\n", CurriedNoSugarFunctorResultInline.result);
/* We would have: */
/* module CurriedSugarWithAnnotation: ASig => BSig => SigResult =
fun (A:ASig) (B:BSig) => {let result = A.a + B.b} */
/*
module Typeahead = React.Create {
type props = {initialCount: int}
type state = {count: int}
let getInitialState props => {count: 10}
let render {props, state} =>
<div>
<span><BigBox></span>
</div>
}
*/
include YourLib.CreateComponent {
type thing = blahblahblah
type state = unit
let getInitialState(_)= ()
let myValue = {
recordField: "hello"
}
}
module type HasInt = {let x: int}
module MyModule = {let x = 10}
let myFirstClass = (module MyModule : HasInt)
let myFirstClassWillBeFormattedAs: (module HasInt) = (module MyModule)
let acceptsAndUnpacksFirstClass ((module M : HasInt)) = M.x + M.x
let acceptsAndUnpacksFirstClass ((module M) : (module HasInt)) = M.x + M.x
module SecondClass = (val myFirstClass)
module SecondClass2 = (val (module MyModule: HasInt))
let p = SecondClass.x
/* Opening Modules */
module M = {
module Inner = {}
}
module N = {
open M
let z = { open M; 34 }
let z = { open M; 34; 35 }
let z = { open M; (34, 35) }
let z = M.(34, 35)
let z = M.((34, 35))
let z = { open M; {} }
let z = M.{}
let z = M.({})
let z = { open M; {x:10} }
let z = { open M; [foo, bar] }
let z = { open M; ([foo, bar]) }
let z = { open M; ({x: 10, y:20}) }
let z = { open M let open M2; value }
let z = { open M; M2.value }
let z = { open! M; 34 }
let z = { open! M; 34; 35 }
let z = { open! M; {} }
let z = { open! M; {x:10} }
let z = { open! M; [foo, bar] }
let z = { open! M; ([foo, bar]) }
let z = { open! M; ({x: 10, y:20}) }
let z = { open! M let open! M2; value }
let z = { open! M; M2.value }
let y = 44
}
open M
open M.Inner
open M
let module OldModuleSyntax = {
let module InnerOldModule = {
}
}
module type SigWithModuleTypeOf = {
module type ModuleType
include (module type of String)
include (module type of Array)
}
module type T = t with type t = (a) => a
module type T = t with type t = ((a) => a)
module type T = (t with type t = a) => a
module X = [%test extension]
module type T = [%test extension]
let foo (type a, (module X): (module X_t with type t =a)) = X.a
let f = ((module M): (module M with type x = x and type y = y)) => M.x
let test = b => {
if (b) {
ignore();
}
while (x) {
compute()
}
try (x()) {
| _ => log()
}
switch (test) {
| A => ()
| B => ()
}
for (x in 0 to 10) {
print_int(x)
print_string(" ")
}
assert(true)
lazy true
Fun.ignore()
}
================================================
FILE: test/modules_no_semi.t/run.t
================================================
Format modules no semi
$ refmt ./input.re
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
let run = () => {
TestUtils.printSection("Modules");
};
/**
* Modules:
* ----------------------------------------------------------------------------
* Modules accomplish the following:
* - Organization of code and data.
* - Basis for separate compilation and fast compile times.
* - Enabled higher order type abstractions that are capable of modelling very
* sophisticated typing relationships between various parts of your code.
*
* Modules are much like records, but much more powerful. Much of modules'
* powers are derived from the fact that they are primarily built up and
* organized at compilation time, instead of runtime. It is this constraint
* that allows modules to be more powerful than simple records.
*
* There are some important ways that modules differ from records:
*
* - Fields are lexically scoped: In the following record: `{x:1, y: x + x}`,
* the reference to `x` does not refer to the record field `x`. This is because
* records fields do not form lexical scopes for the evaluation of other record
* values. Modules, on the other hand do allow fields to reference other
* fields. Appropriately, each field is introduced via the keyword `let`.
*/
module MyFirstModule = {
let x = 0;
let y = x + x;
};
let result = MyFirstModule.x + MyFirstModule.y;
/**
* - A module is introduced with the `module` phrase.
* - A module *must* have a capital letter as its first character.
* - The exported fields of a module must be listed within `{}` braces and each
* exported value binding is specified via a `let` keyword.
*/
/**
* Another way that modules are more powerful than records, is that they may
* also export types.
*/
module MySecondModule = {
type someType = int;
let x = 0;
let y = x + x;
};
let myInt: MySecondModule.someType = 100;
/** Module signatures:
* ----------------------------------------------------------------------------
* Not only may modules export types, but modules *themselves* can be described
* by types via the `module type` phrase. We call these module types
* "signatures". For example, `MySecondModule` has the following `module type`
* signature:
*/
module type MySecondModuleType = {
type someType = int;
let x: int;
let y: int;
};
/**
* Much like how you can ensure that a value is compatible with a specific
* type:
let myTestVal: int = 10
* You can also perform the same type of annotation to ensure that you have
* written code that matches your understanding. For example, `MySecondModule`
* could have been written as:
module MySecondModule: MySecondModuleType = {
type someType = int
let x = 0
let y = x + x
}
*/
/**
* - Modules may be artificially "constrained" so that users of a module see
* fewer details than are actually present.
* - Modules may be combined, merged, and transformed at compile time in ways
* that
* - Because they are more powerful, they may not be passed around at runtime
* as easily as records.
*
* Some additioal benefits to using modules:
* - Modules are a very elegant way to organize large packages of code.
* - Modules are the unit of compilation. Minimal recompilation changes
* - Modules can help you achieve higher degrees of polymorphism than the core
* language.
*/
let opensAModuleLocally = {
module MyLocalModule = {
type i = int;
let x: i = 10;
};
/* Notice how local modules names may be used twice and are shadowed */
module MyLocalModule: MySecondModuleType = {
type someType = int;
let x: someType = 10;
let y: someType = 20;
};
let tmp = MyLocalModule.x + 22;
tmp + 30;
};
module type HasTT = {
type tt;
};
module SubModule: HasTT = {
type tt = int;
};
module type HasEmbeddedHasTT = {
module SubModuleThatHasTT = SubModule;
};
module type HasPolyType = {
type t('a);
};
module type HasDestructivelySubstitutedPolyType =
HasPolyType with type t('a) := list('a);
module type HasDestructivelySubstitutedSubPolyModule = {
/* Cannot perform destructive substitution on submodules! */
/* module X: HasPolyType with type t := list (int, int) */
module X: HasDestructivelySubstitutedPolyType;
};
module type HasSubPolyModule = {
/* Cannot perform destructive substitution on submodules! */
/* module X: HasPolyType with type t := list (int, int) */
module X: HasPolyType;
};
module EmbedsSubPolyModule: HasSubPolyModule = {
module X = {
type t('a) = list('a);
};
};
module EmbedsDestructivelySubstitutedPolyModule:
HasDestructivelySubstitutedSubPolyModule = {
module X = {
type t = list(int, int);
};
};
module type HasMultiPolyType = {
type substituteThis('a, 'b);
type substituteThat('a, 'b);
};
module type HasDestructivelySubstitutedMultiPolyType =
HasMultiPolyType with
type substituteThis('a, 'b) :=
Hashtbl.t('a, 'b) and
type substituteThat('a, 'b) :=
Hashtbl.t('a, 'b);
module InliningSig: {
let x: int;
let y: int;
} = {
/*
* Comment inside of signature.
*/
let x = 10;
/* Inline comment inside signature. */
let y = 20;
};
module MyFunctor = (M: HasTT) => {
type reexportedTT = M.tt;
/* Inline comment inside module. */
/** Following special comment inside module. */
let someValue = 1000;
};
/* Notice how
- Functors no longer require parens around argument.
- A final semicolon is required for module structures.
- We should eliminate both those requirements. See action items 13-14 at the
bottom of this file. [Actually, forgiving the trailing SEMI might not be
such a great idea].
*/
module MyFunctorResult =
MyFunctor({
type tt = string;
});
module LookNoParensNeeded =
MyFunctor({
type tt = string;
});
module type SigResult = {
let result: int;
};
module type ASig = {
let a: int;
};
module type BSig = {
let b: int;
};
module AMod = {
let a = 10;
};
module BMod = {
let b = 10;
};
module CurriedSugar = (A: ASig, B: BSig) => {
let result = A.a + B.b;
};
/* Right now [CurriedSuperSugar] is parsed as being indistinguishable from
the above.
module CurriedSuperSugar (A:ASig) (B:BSig): SigResult => ({
let result = A.a + B.b
}: SigResult)
/* Not supported in OCaml OR Reason (Edit: now supported in OCaml for functions) */
let x = fun (a:foo) :bar => baz
module x = fun (A:Foo) :Bar => Baz
/* Supported in both OCaml and Reason */
let x (a:foo) :bar => baz
module x (A:Foo) :Bar => Baz
*/
module CurriedSugarWithReturnType =
(A: ASig, B: BSig)
: SigResult => {
let result = A.a + B.b;
};
/* This is parsed as being equivalent to the above example */
module CurriedSugarWithAnnotatedReturnVal =
(A: ASig, B: BSig)
: SigResult => {
let result = A.a + B.b;
};
module CurriedNoSugar = (A: ASig, B: BSig) => {
let result = A.a + B.b;
};
let letsTryThatSyntaxInLocalModuleBindings = () => {
module CurriedSugarWithReturnType =
(A: ASig, B: BSig)
: SigResult => {
let result = A.a + B.b;
};
module CurriedSugarWithAnnotatedReturnVal =
(A: ASig, B: BSig)
: SigResult => {
let result = A.a + B.b;
};
module CurriedNoSugar = (A: ASig, B: BSig) => {
let result = A.a + B.b;
};
/*
* The following doesn't work in OCaml (LocalModule (struct end)).x isn't even
* parsed!
*
* let thisDoesntWorkInOCaml () =
* module LocalModule(A:sig end) = struct let x = 10 end in
* module Out = (LocalModule (struct end)) in
* let outVal = (LocalModule (struct end)).x in
* let res = Out.x in
* res
*/
module TempModule =
CurriedNoSugar(AMod, BMod);
module TempModule2 =
CurriedSugarWithAnnotatedReturnVal(
AMod,
BMod,
);
TempModule.result + TempModule2.result;
};
module type EmptySig = {};
module MakeAModule = (X: EmptySig) => {
let a = 10;
};
module CurriedSugarFunctorResult =
CurriedSugar(AMod, BMod);
module CurriedSugarFunctorResultInline =
CurriedSugar(
{
let a = 10;
},
{
let b = 10;
},
);
module CurriedNoSugarFunctorResult =
CurriedNoSugar(AMod, BMod);
module CurriedNoSugarFunctorResultInline =
CurriedNoSugar(
{
let a = 10;
},
{
let b = 10;
},
);
module ResultFromNonSimpleFunctorArg =
CurriedNoSugar(MakeAModule(), BMod);
/* TODO: Functor type signatures should more resemble value signatures */
let curriedFunc: (int, int) => int = (a, b) =>
a + b;
module type FunctorType =
(ASig, BSig) => SigResult;
/* Which is sugar for:*/
module type FunctorType2 =
(ASig, BSig) => SigResult;
/* Just for compability with existing OCaml ASTs you can put something other
* than an underscore */
module type FunctorType3 =
(Blah: ASig, ThisIsIgnored: BSig) => SigResult;
/* The actual functors themselves now have curried sugar (which the pretty
* printer will enforce as well */
/* The following: */
module CurriedSugarWithAnnotation2:
(ASig, BSig) => SigResult =
(A: ASig, B: BSig) => {
let result = A.a + B.b;
};
/* Becomes: */
module CurriedSugarWithAnnotation:
(ASig, BSig) => SigResult =
(A: ASig, B: BSig) => {
let result = A.a + B.b;
};
/* "functors" that are not in sugar curried form cannot annotate a return type
* for now, so we settle for: */
module CurriedSugarWithAnnotationAndReturnAnnotated:
(ASig, BSig) => SigResult =
(A: ASig, B: BSig) => (
{
let result = A.a + B.b;
}:
SigResult
);
module ReturnsAFunctor =
(A: ASig, B: BSig)
: ((ASig, BSig) => SigResult) =>
(A: ASig, B: BSig) => {
let result = 10;
};
module ReturnsSigResult =
(A: ASig, B: BSig)
: SigResult => {
let result = 10;
};
module ReturnsAFunctor2 =
(A: ASig, B: BSig)
: ((ASig, BSig) => SigResult) =>
(A: ASig, B: BSig) => {
let result = 10;
};
/*
* Recursive modules.
* TODO: Test [Psig_recmodule]
*/
module rec A: {
type t =
| Leaf(string)
| Node(ASet.t);
let compare: (t, t) => int;
} = {
type t =
| Leaf(string)
| Node(ASet.t);
let compare = (t1, t2) =>
switch (t1, t2) {
| (Leaf(s1), Leaf(s2)) =>
Pervasives.compare(s1, s2)
| (Leaf(_), Node(_)) => 1
| (Node(_), Leaf(_)) => (-1)
| (Node(n1), Node(n2)) =>
ASet.compare(n1, n2)
};
}
and ASet: Set.S with type elt = A.t =
Set.Make(A);
/*
* How recursive modules appear in signatures.
*/
module type HasRecursiveModules = {
module rec A: {
type t =
| Leaf(string)
| Node(ASet.t);
let compare: (t, t) => int;
}
and ASet: Set.S with type elt = A.t;
};
/* From http://stackoverflow.com/questions/1986374/higher-order-type-constructors-and-functors-in-ocaml */
module type Type = {
type t;
};
module Char = {
type t = char;
};
module List = (X: Type) => {
type t = list(X.t);
};
module Maybe = (X: Type) => {
type t = option(X.t);
};
module Id = (X: Type) => X;
module Compose =
(
F: (Type) => Type,
G: (Type) => Type,
X: Type,
) =>
F(G(X));
let l: Compose(List)(Maybe)(Char).t = [
Some('a'),
];
module Example2 = (F: (Type) => Type, X: Type) => {
/**
* Note: This is the one remaining syntactic issue where
* modules/functions do not have syntax unified with values.
* It should be:
*
* let iso (a:(Compose Id F X).t): (F X).t => a
*
*/
let iso = (a: Compose(Id)(F)(X).t): F(X).t => a;
};
Printf.printf(
"\nModules And Functors: %n\n",
CurriedNoSugarFunctorResultInline.result,
);
/* We would have: */
/* module CurriedSugarWithAnnotation: ASig => BSig => SigResult =
fun (A:ASig) (B:BSig) => {let result = A.a + B.b} */
/*
module Typeahead = React.Create {
type props = {initialCount: int}
type state = {count: int}
let getInitialState props => {count: 10}
let render {props, state} =>
<div>
<span><BigBox></span>
</div>
}
*/
include YourLib.CreateComponent({
type thing = blahblahblah;
type state = unit;
let getInitialState = _ => ();
let myValue = { recordField: "hello" };
});
module type HasInt = {
let x: int;
};
module MyModule = {
let x = 10;
};
let myFirstClass: module HasInt =
(module MyModule);
let myFirstClassWillBeFormattedAs: (module HasInt) =
(module MyModule);
let acceptsAndUnpacksFirstClass =
(module M: HasInt) =>
M.x + M.x;
let acceptsAndUnpacksFirstClass =
(module M: HasInt) =>
M.x + M.x;
module SecondClass = (val myFirstClass);
module SecondClass2 = (
val (module MyModule): HasInt
);
let p = SecondClass.x;
/* Opening Modules */
module M = {
module Inner = {};
};
module N = {
open M;
let z = {
M.(34);
};
let z = {
open M;
34;
35;
};
let z = {
M.(34, 35);
};
let z = M.(34, 35);
let z = M.(34, 35);
let z = {
M.{};
};
let z = M.{};
let z = M.{};
let z = {
M.{ x: 10 };
};
let z = {
M.[foo, bar];
};
let z = {
M.[foo, bar];
};
let z = {
M.{
x: 10,
y: 20,
};
};
let z = {
M.(M2.(value));
};
let z = {
M.(M2.value);
};
let z = {
open! M;
34;
};
let z = {
open! M;
34;
35;
};
let z = {
open! M;
{};
};
let z = {
open! M;
{ x: 10 };
};
let z = {
open! M;
[foo, bar];
};
let z = {
open! M;
[foo, bar];
};
let z = {
open! M;
{
x: 10,
y: 20,
};
};
let z = {
open! M;
open! M2;
value;
};
let z = {
open! M;
M2.value;
};
let y = 44;
};
open M;
open M.Inner;
open M;
module OldModuleSyntax = {
module InnerOldModule = {};
};
module type SigWithModuleTypeOf = {
module type ModuleType;
include (module type of String);
include (module type of Array);
};
module type T = t with type t = a => a;
module type T = t with type t = a => a;
module type T = (t with type t = a) => a;
module X = [%test extension];
module type T = [%test extension];
let foo =
(type a, module X: X_t with type t = a) => X.a;
let f =
(module M: M with type x = x and type y = y) => M.x;
let test = b => {
if (b) {
ignore();
};
while (x) {
compute();
};
try(x()) {
| _ => log()
};
switch (test) {
| A => ()
| B => ()
};
for (x in 0 to 10) {
print_int(x);
print_string(" ");
};
assert(true);
lazy(true);
Fun.ignore();
};
/* From http://stackoverflow.com/questions/1986374/ higher-order-type-constructors-and-functors-in-ocaml */
================================================
FILE: test/mutation.t/input.re
================================================
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
/**
* Testing mutations.
*/
let holdsAUnit = ref();
let holdsABool = ref(false);
let holdsAnInt = ref(0);
let holdsAHoldsABool = ref(ref(true));
let () = holdsAUnit := holdsABool := false;
/* Should be parsed as: */
/* And so they should both be printed the same */
let () = holdsAUnit := (holdsABool := false);
/*
* The following:
*
* something = x := e
*
* Should be parsed as:
*
* something = (x := e)
*/
holdsAUnit.contents = holdsAnInt := 0;
holdsABool.contents = holdsAnInt.contents == 100;
let numberToSwitchOn = 100;
switch (numberToSwitchOn) {
| -3
| -2
| -1 => ()
| 0 => holdsAUnit.contents = ()
| 1 => holdsAUnit.contents = holdsAnInt := 0
| 2 => true ? holdsAUnit.contents = () : holdsABool.contents ? () : ()
| 3 => true ? holdsAUnit := () : holdsABool.contents ? () : ()
| 4 => true ? holdsAnInt := 40 : ()
| 5 => holdsAnInt := 40
| _ => ()
};
let mutativeFunction = fun | Some(x) => holdsAUnit.contents = ()
| None => holdsAUnit := ();
================================================
FILE: test/mutation.t/run.t
================================================
Format basic
$ refmt --print re ./input.re > ./formatted.re
Print the formatted file
$ cat ./formatted.re
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
/**
* Testing mutations.
*/
let holdsAUnit = ref();
let holdsABool = ref(false);
let holdsAnInt = ref(0);
let holdsAHoldsABool = ref(ref(true));
let () = holdsAUnit := holdsABool := false;
/* Should be parsed as: */
/* And so they should both be printed the same */
let () = holdsAUnit := holdsABool := false;
/*
* The following:
*
* something = x := e
*
* Should be parsed as:
*
* something = (x := e)
*/
holdsAUnit.contents = holdsAnInt := 0;
holdsABool.contents = holdsAnInt.contents == 100;
let numberToSwitchOn = 100;
switch (numberToSwitchOn) {
| (-3)
| (-2)
| (-1) => ()
| 0 => holdsAUnit.contents = ()
| 1 => holdsAUnit.contents = holdsAnInt := 0
| 2 =>
true
? holdsAUnit.contents = ()
: holdsABool.contents ? () : ()
| 3 =>
true
? holdsAUnit := ()
: holdsABool.contents ? () : ()
| 4 => true ? holdsAnInt := 40 : ()
| 5 => holdsAnInt := 40
| _ => ()
};
let mutativeFunction =
fun
| Some(x) => holdsAUnit.contents = ()
| None => holdsAUnit := ();
Type-check basics
$ ocamlc -c -pp 'refmt --print binary' -intf-suffix .rei -impl formatted.re
Format the formatted file back
$ refmt --print re ./formatted.re > ./formatted_back.re
Ensure idempotency: first format and second format are the same
$ diff formatted.re formatted_back.re
================================================
FILE: test/object.t/input.re
================================================
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
type t = {.};
type t = {
.
u: int,
v: int
};
type t = {.. u: int};
type t = {.. u: int};
type t = {
..
};
type t = {..};
let (<..>)(a,b) = a + b;
let five = 2 <..> 3;
type closedObjSugar = Js.t({. foo: bar, baz: int});
type openObjSugar = Js.t({.. x: int, y: int});
type x = Js.t({.});
type y = Js.t({..});
/* #1595: always break object rows (>= 2) for readability */
type o = {
.
a: int,
b: int
};
type o2 = {
..
a: int,
b: int
};
let obj = {as _; [@foo] val a = 1};
/* Oinherit (https://github.com/ocaml/ocaml/pull/1118) */
type t1 = {
.
n: string,
...t,
};
type t1 = {
..
n: string,
...t,
};
type g1 = {
.
n: string,
...t,
...y,
};
type g2 = {
.
n: string,
...t,
...y,
};
type m1 = {
.
...M.t,
};
type m2('a) = {
.
n: string,
...M.t('a),
};
================================================
FILE: test/object.t/run.t
================================================
Format objects
$ refmt ./input.re
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
type t = {.};
type t = {
.
u: int,
v: int,
};
type t = {.. u: int };
type t = {.. u: int };
type t = {..};
type t = {..};
let (<..>) = (a, b) => a + b;
let five = 2 <..> 3;
type closedObjSugar = {
.
"foo": bar,
"baz": int,
};
type openObjSugar = {
..
"x": int,
"y": int,
};
type x = Js.t({.});
type y = Js.t({..});
/* #1595: always break object rows (>= 2) for readability */
type o = {
.
a: int,
b: int,
};
type o2 = {
..
a: int,
b: int,
};
let obj = { as _; [@foo] val a = 1 };
/* Oinherit (https://github.com/ocaml/ocaml/pull/1118) */
type t1 = {
.
n: string,
...t,
};
type t1 = {
..
n: string,
...t,
};
type g1 = {
.
n: string,
...t,
...y,
};
type g2 = {
.
n: string,
...t,
...y,
};
type m1 = {. ...M.t };
type m2('a) = {
.
n: string,
...M.t('a),
};
================================================
FILE: test/ocaml_identifiers.t/input.ml
================================================
(* Type names (supported with PR#2342) *)
module T = struct
type pub = unit
end
(* Value names (already supported) *)
module V = struct
let method_ = ()
end
(* Record fields *)
module R = struct
type r = { mutable method_ : int }
let foo = { method_ = 4 }
let x = foo.method_
let () = foo.method_ <- 42
let y = match foo with {method_} -> method_
let z = match foo with {method_=12} -> 21
end
(* Class names and instance variables *)
module C = struct
class pub = object end
class c = object
val pub = 0
method method_ () = ()
end
class c' = object
inherit method_
val! pub = 1
end
end
(* Class types *)
module Ct = struct
class type method_ = object
val method_: unit -> unit
end
end
(* Virtual *)
module Cv = struct
class virtual method_ = object end
end
(* Object methods *)
module O = struct
let o = object method method_ = () end
end
(* Function parameter labels *)
module L = struct
let f ~method_ = ignore method_
end
(* Module types *)
module type method_ = sig
end
(* Polymorphic variants (probably ok as-is?) *)
module P = struct
type t = [ `pub | `method_ ]
let x = `method_
let () = fun `method_ -> 34
end
type method_ = string
type foo = {method_: method_}
[@@some_attr: type_]
[@@other_attr: method_]
let f ~method_ = Js.log(method_)
let x = f ~method_:"GET"
type marshalFields = < switch: string > Js.t
let testMarshalFields = ([%mel.obj { switch = "switch" }] : marshalFields)
(* Not an identifier test, but this is testing OCaml -> RE *)
let x = List.map (fun y ->
();
y)
let newType (type method_) () = ()
================================================
FILE: test/ocaml_identifiers.t/run.t
================================================
Format OCaml identifiers file
$ refmt ./input.ml --print re
/* Type names (supported with PR#2342) */
module T = {
type pub_ = unit;
};
/* Value names (already supported) */
module V = {
let method = ();
};
/* Record fields */
module R = {
type r = {mutable method_: int};
let foo = { method_: 4 };
let x = foo.method_;
let () = foo.method_ = 42;
let y =
switch (foo) {
| { method_: method } => method
};
let z =
switch (foo) {
| { method_: 12 } => 21
};
};
/* Class names and instance variables */
module C = {
class pub_ = {
as _;
};
class c = {
as _;
val pub_ = 0;
pub method = () => ();
};
class c' = {
as _;
inherit class method;
val! pub_ = 1;
};
};
/* Class types */
module Ct = {
class type method = {
val method: unit => unit;
};
};
/* Virtual */
module Cv = {
class virtual method = {
as _;
};
};
/* Object methods */
module O = {
let o = { as _; pub method = () };
};
/* Function parameter labels */
module L = {
let f = (~method_ as method) =>
ignore(method);
};
/* Module types */
module type method = {};
/* Polymorphic variants (probably ok as-is?) */
module P = {
type t = [
| `pub_
| `method
];
let x = `method;
let () = (`method) => 34;
};
type method = string;
[@some_attr: type_]
[@other_attr: method]
type foo = {method_: method};
let f = (~method_ as method) => Js.log(method);
let x = f(~method_="GET");
type marshalFields = {. "switch": string };
let testMarshalFields: marshalFields = {
"switch": "switch",
};
/* Not an identifier test, but this is testing OCaml -> RE */
let x =
List.map(y => {
();
y;
});
let newType = (type method, ()) => ();
================================================
FILE: test/oo.t/input.re
================================================
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
class virtual stack('a)(init) {
/*
* The "as this" is implicit and will be formatted away.
*/
as this;
val virtual dummy : unit;
val mutable v : list('a) = init;
pub virtual implementMe: (int) => int;
pub pop =
switch (v) {
| [hd, ...tl] => {
v = tl;
Some(hd);
}
| [] => None
};
pub push(hd) {v = [hd, ...v]};
initializer {
print_string("initializing object");
};
pub explicitOverrideTest(a) { a + 1 };
pri explicitOverrideTest2(a) { a + 1 };
};
let tmp = {
/**
* comment here.
*/
as this;
val x = 10;
};
/**
* Comment on stackWithAttributes.
*/
[@thisShouldntBeFormattedAway]
class virtual stackWithAttributes('a)(init)
/* Before class */
{
/* The "as this" should not be formatted away because attributes. */
as [@thisShouldntBeFormattedAway] this;
/* Before floatting attribute */
[@floatingAttribute];
/* Virtual member */
[@itemAttr1]
val virtual dummy : unit;
[@itemAttr2]
val mutable v : list('a) = init;
pub virtual implementMe: (int) => int;
pub pop =
switch (v) {
| [hd, ...tl] => {
v = tl;
Some(hd);
}
| [] => None
};
pub push(hd) {v = [hd, ...v]};
initializer {
print_string("initializing object");
};
}
;
class extendedStack('a)(init) {
inherit (class stack('a))(init);
val dummy = ();
pub implementMe(i) = i;
};
class extendedStackAcknowledgeOverride('a)(init) {
inherit (class stack('a))(init);
val dummy = ();
pub implementMe(i) { i + 1 };
pub! explicitOverrideTest(a) { a + 2 };
pri! explicitOverrideTest2(a) { a + 2 };
};
let inst = new extendedStack([1, 2]);
/**
* Recursive classes.
*/
/*
* First recursive class.
*/
class firstRecursiveClass(init) {
val v = init;
}
/*
* Second recursive class.
*/
and secondRecursiveClass(init) {
val v = init;
};
/**
* For now, mostly for historic reasons, the syntax for type
* definitions/annotations on anonymous objects are different than
* "class_instance_type". That needn't be the case. The only challenge is that
* whatever we do, there is a slight challenge in avoiding conflicts with
* records. Clearly {x:int, y:int} will conflict. However, open object types in
* the form of {.. x:int, y:int} do not conflict. The only thing that must be
* resolved is closed object types and records. you could have a special token
* that means "closed". {. x: int, y:int}. If only closed object types would be
* optimized in the same way that records are, records could just be replaced
* with closed object types.
*/
/**
* Anonymous objects.
*/
type closedObj = {.};
let (<..>)(a,b) = a + b;
let five = 2 <..> 3;
type nestedObj = {. bar : {. a: int}};
let (>>)(a,b) = a > b;
let bigger = 3 >> 2;
type typeDefForClosedObj = {. x: int, y:int};
type typeDefForOpenObj('a) = {.. x:int, y:int} as 'a;
let anonClosedObject: {. x:int, y:int} = {
pub x { 0 };
pub y { 0 };
};
let onlyHasX = {pub x = 0};
let xs: list({. x:int}) = [onlyHasX, anonClosedObject :> {. x: int}];
let constrainedAndCoerced =
([anonClosedObject, anonClosedObject] : list({. x:int, y:int}) :> list({. x:int}));
/* If one day, unparenthesized type constraints are allowed on the RHS of a
* record value, we're going to have to be careful here because >} is parsed as
* a separate kind of token (for now). Any issues would likely be caught in the
* idempotent test case.
*/
let xs: ref({. x:int}) = {contents: (anonClosedObject :> {. x: int})};
let coercedReturn = {
let tmp = anonClosedObject;
(tmp :> {. x: int})
};
let acceptsOpenAnonObjAsArg (o: {.. x: int, y:int}) = o#x + o#y;
let acceptsClosedAnonObjAsArg (o: {. x: int, y:int}) = o#x + o#y;
let res = acceptsOpenAnonObjAsArg {
pub x = 0;
pub y = 10;
};
let res = acceptsOpenAnonObjAsArg {
pub x = 0;
pub y = 10;
pub z = 10;
};
let res = acceptsClosedAnonObjAsArg {
pub x = 0;
pub y = 10;
};
/* TODO: Unify class constructor return values with function return values */
class myClassWithAnnotatedReturnType(init) : {pub x : int; pub y : int} {
pub x = ( init : int );
pub y = init;
};
/**
* May include a trailing semi after type row.
*/
class myClassWithAnnotatedReturnType2(init):{pub x : int; pub y : int;} {
pub x = ( init : int );
pub y = init;
};
/**
* May use equals sign, and may include colon if so.
*/
class myClassWithAnnotatedReturnType3(init):{pub x : int; pub y : int;} {
pub x = ( init : int );
pub y:int = init;
};
/**
* The one difference between class_constructor_types and expression
* constraints, is that we have to include the prefix word "new" before the
* final component of any arrow. This isn't required when annotating just the
* return value with ": foo ".
* This is only to temporarily work around a parsing conflict. (Can't tell if
* in the final arrow component it should begin parsing a non_arrowed_core_type
* or a class_instance_type). A better solution, would be to include
* class_instance_type as *part* of core_type, but then fail when it is
* observed in the non-last arrow position, or if a non_arrowed_core_type
* appears in the last arrow position.
*
* class_instance_type wouldn't always fail if parsed as any "core type"
* everywhere else in the grammar.
*
* Once nuance to that would be making a parse rule for "type application", and
* deferring whether or not that becomes a Pcty_constr or a Ptyp_constr. (The
* same for type identifiers and extensions.)
*/
class myClassWithAnnotatedReturnType3_annotated_constructor :
(int) => {pub x : int; pub y : int;} =
(init) => {
pub x = ( init : int );
pub y:int = init;
};
class tupleClass('a,'b) (init: ('a, 'b)) {
pub pr = init;
};
module HasTupleClasses : {
/**
* exportedClass.
*/
class exportedClass: (int) => {pub x : int; pub y : int};
/**
* anotherExportedClass.
*/
class anotherExportedClass('a,'b) : (('a, 'b)) => {pub pr: ('a, 'b)};
} = {
/**
* exportedClass.
*/
class exportedClass = myClassWithAnnotatedReturnType3;
/**
* anotherExportedClass.
*/
class anotherExportedClass('a,'b) = (class tupleClass('a,'b));
};
class intTuples = (class tupleClass(int,int));
class intTuplesHardcoded = (class tupleClass(int,int))((8, 8));
/**
* Note that the inner tupleClass doesn't have the "class" prefix because
* they're not kinds of classes - they're types of *values*.
* The parens here shouldn't be required.
*/
class intTuplesTuples = (
class tupleClass(
(tupleClass(int,int)),
(tupleClass(int,int))
)
);
let x: tupleClass(int,int) = {pub pr = (10, 10);};
let x: #tupleClass(int,int) = x;
let incrementMyClassInstance: (int, #tupleClass(int,int)) => #tupleClass(int,int) =
(i,inst) => {
let (x, y) = inst#pr;
{pub pr = (x + i, y + i);};
};
class myClassWithNoTypeParams = {};
/**
* The #myClassWithNoTypeParams should be treated as "simple"
*/
type optionalMyClassSubtype('a) = option(#myClassWithNoTypeParams) as 'a;
/**
* Remember, "class type" is really "class_instance_type" (which is the type of
* what is returned from the constructor).
*
* And when defining a class:
*
* addablePoint is the "class instance type" type generated in scope which is
* the closed object type of the return value of the constructor.
*
* #addablePoint is the extensible form of addablePoint (anything that
* adheres to the "interface.")
*/
class type addablePointClassType = {
pub x: int;
pub y: int;
pub add: (addablePointClassType, addablePointClassType) => int;
};
/**
* Class constructor types can be annotated.
*/
class addablePoint: (int) => addablePointClassType = fun(init) => {
as self;
pub add (one: addablePointClassType, two:addablePointClassType) =
one#x + two#x + one#y + two#x;
pub x = (init : int);
pub y = init;
};
class addablePoint2 = (fun(init) => {
as self;
pub add (one: addablePointClassType, two:addablePointClassType) =
one#x + two#x + one#y + two#x;
pub x = (init : int);
pub y = init;
} : (int) => addablePointClassType);
module type T = {
class virtual cl('a) : {}
and cl2 : {};
};
let privacy = {
pri x(c) = 5 + c;
};
module Js = {
type t('a);
};
/* supports trailing comma */
type stream('a) = {. "observer": ('a => unit) => unit,};
================================================
FILE: test/oo.t/run.t
================================================
Format basic
$ refmt --print re ./input.re > ./formatted.re
Print the formatted file
$ cat ./formatted.re
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
class virtual stack ('a) (init) = {
/*
* The "as this" is implicit and will be formatted away.
*/
val virtual dummy: unit;
val mutable v: list('a) = init;
pub virtual implementMe: int => int;
pub pop =
switch (v) {
| [hd, ...tl] =>
v = tl;
Some(hd);
| [] => None
};
pub push = hd => {
v = [hd, ...v];
};
initializer {
print_string("initializing object");
};
pub explicitOverrideTest = a => {
a + 1;
};
pri explicitOverrideTest2 = a => {
a + 1;
};
};
let tmp = {
/**
* comment here.
*/;
val x = 10
};
/**
* Comment on stackWithAttributes.
*/
[@thisShouldntBeFormattedAway]
class virtual stackWithAttributes ('a) (init) = {
/* Before class */
/* The "as this" should not be formatted away because attributes. */
as [@thisShouldntBeFormattedAway] this;
/* Before floatting attribute */
[@floatingAttribute];
/* Virtual member */
[@itemAttr1] val virtual dummy: unit;
[@itemAttr2] val mutable v: list('a) = init;
pub virtual implementMe: int => int;
pub pop =
switch (v) {
| [hd, ...tl] =>
v = tl;
Some(hd);
| [] => None
};
pub push = hd => {
v = [hd, ...v];
};
initializer {
print_string("initializing object");
};
};
class extendedStack ('a) (init) = {
inherit (class stack('a))(init);
val dummy = ();
pub implementMe = i => i;
};
class extendedStackAcknowledgeOverride
('a)
(init) = {
inherit (class stack('a))(init);
val dummy = ();
pub implementMe = i => {
i + 1;
};
pub! explicitOverrideTest = a => {
a + 2;
};
pri! explicitOverrideTest2 = a => {
a + 2;
};
};
let inst = (new extendedStack)([1, 2]);
/**
* Recursive classes.
*/
/*
* First recursive class.
*/
class firstRecursiveClass (init) = {
val v = init;
}
/*
* Second recursive class.
*/
and secondRecursiveClass (init) = {
val v = init;
};
/**
* For now, mostly for historic reasons, the syntax for type
* definitions/annotations on anonymous objects are different than
* "class_instance_type". That needn't be the case. The only challenge is that
* whatever we do, there is a slight challenge in avoiding conflicts with
* records. Clearly {x:int, y:int} will conflict. However, open object types in
* the form of {.. x:int, y:int} do not conflict. The only thing that must be
* resolved is closed object types and records. you could have a special token
* that means "closed". {. x: int, y:int}. If only closed object types would be
* optimized in the same way that records are, records could just be replaced
* with closed object types.
*/
/**
* Anonymous objects.
*/
type closedObj = {.};
let (<..>) = (a, b) => a + b;
let five = 2 <..> 3;
type nestedObj = {. bar: {. a: int } };
let (>>) = (a, b) => a > b;
let bigger = 3 >> 2;
type typeDefForClosedObj = {
.
x: int,
y: int,
};
type typeDefForOpenObj('a) =
{
..
x: int,
y: int,
} as 'a;
let anonClosedObject: {
.
x: int,
y: int,
} = {
pub x = {
0;
};
pub y = {
0;
}
};
let onlyHasX = { pub x = 0 };
let xs: list({. x: int }) = [
onlyHasX,
(anonClosedObject :> {. x: int }),
];
let constrainedAndCoerced = (
[anonClosedObject, anonClosedObject]:
list({
.
x: int,
y: int,
}) :>
list({. x: int })
);
/* If one day, unparenthesized type constraints are allowed on the RHS of a
* record value, we're going to have to be careful here because >} is parsed as
* a separate kind of token (for now). Any issues would likely be caught in the
* idempotent test case.
*/
let xs: ref({. x: int }) = {
contents: (anonClosedObject :> {. x: int }),
};
let coercedReturn = {
let tmp = anonClosedObject;
(tmp :> {. x: int });
};
let acceptsOpenAnonObjAsArg =
(
o: {
..
x: int,
y: int,
},
) =>
o#x + o#y;
let acceptsClosedAnonObjAsArg =
(
o: {
.
x: int,
y: int,
},
) =>
o#x + o#y;
let res =
acceptsOpenAnonObjAsArg({
pub x = 0;
pub y = 10
});
let res =
acceptsOpenAnonObjAsArg({
pub x = 0;
pub y = 10;
pub z = 10
});
let res =
acceptsClosedAnonObjAsArg({
pub x = 0;
pub y = 10
});
/* TODO: Unify class constructor return values with function return values */
class myClassWithAnnotatedReturnType
(init)
: {
pub x: int;
pub y: int;
} = {
pub x: int = init;
pub y = init;
};
/**
* May include a trailing semi after type row.
*/
class myClassWithAnnotatedReturnType2
(init)
: {
pub x: int;
pub y: int;
} = {
pub x: int = init;
pub y = init;
};
/**
* May use equals sign, and may include colon if so.
*/
class myClassWithAnnotatedReturnType3
(init)
: {
pub x: int;
pub y: int;
} = {
pub x: int = init;
pub y: int = init;
};
/**
* The one difference between class_constructor_types and expression
* constraints, is that we have to include the prefix word "new" before the
* final component of any arrow. This isn't required when annotating just the
* return value with ": foo ".
* This is only to temporarily work around a parsing conflict. (Can't tell if
* in the final arrow component it should begin parsing a non_arrowed_core_type
* or a class_instance_type). A better solution, would be to include
* class_instance_type as *part* of core_type, but then fail when it is
* observed in the non-last arrow position, or if a non_arrowed_core_type
* appears in the last arrow position.
*
* class_instance_type wouldn't always fail if parsed as any "core type"
* everywhere else in the grammar.
*
* Once nuance to that would be making a parse rule for "type application", and
* deferring whether or not that becomes a Pcty_constr or a Ptyp_constr. (The
* same for type identifiers and extensions.)
*/
class myClassWithAnnotatedReturnType3_annotated_constructor:
(int) =>
{
pub x: int;
pub y: int;
} =
fun (init) => {
pub x: int = init;
pub y: int = init;
};
class tupleClass ('a, 'b) (init: ('a, 'b)) = {
pub pr = init;
};
module HasTupleClasses: {
/**
* exportedClass.
*/
class exportedClass:
(int) =>
{
pub x: int;
pub y: int;
};
/**
* anotherExportedClass.
*/
class anotherExportedClass ('a, 'b):
(('a, 'b)) =>
{
pub pr: ('a, 'b);
};
} = {
/**
* exportedClass.
*/
class exportedClass =
class myClassWithAnnotatedReturnType3;
/**
* anotherExportedClass.
*/
class anotherExportedClass ('a, 'b) =
class tupleClass('a, 'b);
};
class intTuples = class tupleClass(int, int);
class intTuplesHardcoded =
(class tupleClass(int, int))((8, 8));
/**
* Note that the inner tupleClass doesn't have the "class" prefix because
* they're not kinds of classes - they're types of *values*.
* The parens here shouldn't be required.
*/
class intTuplesTuples =
class tupleClass(
tupleClass(int, int),
tupleClass(int, int),
);
let x: tupleClass(int, int) = {
pub pr = (10, 10)
};
let x: #tupleClass(int, int) = x;
let incrementMyClassInstance
: (int, #tupleClass(int, int)) =>
#tupleClass(int, int) =
(i, inst) => {
let (x, y) = inst#pr;
{ pub pr = (x + i, y + i) };
};
class myClassWithNoTypeParams = {};
/**
* The #myClassWithNoTypeParams should be treated as "simple"
*/
type optionalMyClassSubtype('a) =
option(#myClassWithNoTypeParams) as 'a;
/**
* Remember, "class type" is really "class_instance_type" (which is the type of
* what is returned from the constructor).
*
* And when defining a class:
*
* addablePoint is the "class instance type" type generated in scope which is
* the closed object type of the return value of the constructor.
*
* #addablePoint is the extensible form of addablePoint (anything that
* adheres to the "interface.")
*/
class type addablePointClassType = {
pub x: int;
pub y: int;
pub add:
(
addablePointClassType,
addablePointClassType
) =>
int;
};
/**
* Class constructor types can be annotated.
*/
class addablePoint:
(int) => addablePointClassType =
fun (init) => {
as self;
pub add =
(
one: addablePointClassType,
two: addablePointClassType,
) =>
one#x + two#x + one#y + two#x;
pub x: int = init;
pub y = init;
};
class addablePoint2:
(int) => addablePointClassType =
fun (init) => {
as self;
pub add =
(
one: addablePointClassType,
two: addablePointClassType,
) =>
one#x + two#x + one#y + two#x;
pub x: int = init;
pub y = init;
};
module type T = {
class virtual cl ('a): {}
and cl2: {};
};
let privacy = { pri x = c => 5 + c };
module Js = {
type t('a);
};
/* supports trailing comma */
type stream('a) = {
.
"observer": ('a => unit) => unit,
};
Type-check basics
$ ocamlc -c -pp 'refmt --print binary' -intf-suffix .rei -impl formatted.re
Format the formatted file back
$ refmt --print re ./formatted.re > ./formatted_back.re
Ensure idempotency: first format and second format are the same
$ diff formatted.re formatted_back.re
================================================
FILE: test/patternMatching.t/input.re
================================================
type point = {x: int, y: int};
let id(x) = x;
type myVariant =
| TwoCombos(inner, inner)
| Short
| AlsoHasARecord(int, int, point)
and inner =
| Unused
| HeresTwoConstructorArguments(int, int);
let computeTuple(a,b,c,d,e,f,g,h) = (
a + b,
c + d,
e + f,
g + h
);
let res =
switch (TwoCombos(Unused,Unused)) {
| TwoCombos
(HeresTwoConstructorArguments(x,y),
HeresTwoConstructorArguments(a,b)) =>
(x, y, a, b)
| TwoCombos
(_,
_) => (0, 0, 0, 0)
| Short
| AlsoHasARecord (300,_,_) => (
100000,
100000,
100000,
100000
)
| AlsoHasARecord (firstItem, two, {x, y}) =>
computeTuple(firstItem,firstItem,firstItem,firstItem,firstItem,two,two,two)
};
/**
* Match bodies may include sequence expressions, but without the `{}`
* braces required.
*/
let res =
switch (TwoCombos(Unused,Unused)) {
| TwoCombos
(HeresTwoConstructorArguments(x,y),
HeresTwoConstructorArguments(a,b)) => {
let ret = (x, y, a, b);
ret;
}
| TwoCombos (_,_) =>
/**
* See, no braces required - saves indentation as well!
*/
let ret = (0, 0, 0, 0);
ret;
| Short
| AlsoHasARecord (300,_,_) =>
/**
* And no final semicolon is required.
*/
let ret = (
100000,
100000,
100000,
100000
);
ret
| AlsoHasARecord(firstItem,two,{x, y}) =>
computeTuple(firstItem,firstItem,firstItem,firstItem,firstItem,two,two,two)
};
/**
* Ensure that nested Pexp_functions are correctly wrapped in parens.
*
*/
let res =
switch (TwoCombos(Unused,Unused)) {
| TwoCombos
(HeresTwoConstructorArguments(x,y),
HeresTwoConstructorArguments(a,b)) =>
(fun
| Some(x) => x + 1
| None => 0)
| TwoCombos
(_,
_) =>
let x =
(fun
| Some(x) => x + 1
| None => 0);
x;
| Short
| AlsoHasARecord(300,_,_) => id ((fun
| Some(x) => x + 1
| None => 0))
| AlsoHasARecord(firstItem,two,{x, y}) =>
id ((fun
| Some(x) => x + 1
| None => 0));
};
/* test (), which is sugar for (()) */
switch (Some(())) {
| Some(()) => 1
| _ => 2
};
switch (Some(())) {
| Some() => 1
| _ => 2
};
switch (Some()) {
| Some(()) => 1
| _ => 2
};
switch (Some()) {
| Some() => 1
| _ => 2
};
type foo = Foo(unit);
switch (Foo(())) {
| Foo(()) => 1
};
switch (Foo(())) {
| Foo() => 1
};
switch (Foo()) {
| Foo(()) => 1
};
switch (Foo()) {
| Foo() => 1
};
switch (()) {
| (()) => 1
};
switch (()) {
| () => 1
};
switch () {
| (()) => 1
};
switch () {
| () => 1
};
switch (Some(1)) {
| Some(1) => 1
| None => 2
| _ => 3
};
let myInt = 100;
/* Numeric ranges are rejected by the type checker, but validly parsed so drop
* this in an annotation to test the parsing. */
[@something? 1 .. 2]
let rangeInt = 0;
let myChar = 'x';
let rangeChar =
switch(myChar) {
| 'a'..'b' => "a to b"
| 'b' .. 'z' => "b to z"
| c => "something else"
};
/* with parens around direct list pattern in constructor pattern */
switch (None) {
| Some([]) => ()
| Some([_]) when true => ()
| Some([x]) => ()
| Some([x, ...xs]) when true => ()
| Some([x, y, z]) => ()
| _ => ()
};
/* no parens around direct list pattern in constructor pattern (sugar) */
switch (None) {
| Some [] => ()
| Some [_] when true => ()
| Some [x] => ()
| Some [x, ...xs] when true => ()
| Some [x, y, z] => ()
| _ => ()
};
/* with parens around direct array pattern in constructor pattern */
switch (None) {
| Some([| |]) => "empty"
| Some([| _ |]) when true => "one any"
| Some([| a |]) => "one"
| Some([| a, b |]) => "two"
| _ => "many"
};
/* no parens around direct array pattern in constructor pattern (sugar) */
switch (None) {
| Some [||] => "empty"
| Some [|_|] when true => "one any"
| Some [|a|] => "one"
| Some [|a, b|] => "two"
| _ => "many"
};
/* parens around direct record pattern in constructor pattern */
switch (None) {
| Some({x}) when true => ()
| Some({x, y}) => ()
| _ => ()
};
/* no parens around direct record pattern in constructor pattern (sugar) */
switch (None) {
| Some {x} when true => ()
| Some {x, y} => ()
| _ => ()
};
switch (None) {
| Some([|someSuperLongString, thisShouldBreakTheLine|]) => ()
| _ => ()
};
switch (None) {
| Some((someSuperLongString, thisShouldBreakTheLine)) => ()
| _ => ()
};
switch (None) {
| Some([someSuperLongString, thisShouldBreakTheLine]) => ()
| Some([someSuperLongString, ...es6ListSugarLikeSyntaxWhichIsSuperLong]) when true === true => ()
| Some([someSuperLongString, ...es6ListSugarLikeSyntaxWhichIsSuperLong]) => ()
| _ => ()
}
type aOrB = A(int) | B(int);
let ((nestedAnnotation: int) : int) = 0;
let ((A(i) | B(i): aOrB)) = A(0);
type test_foo =
| VariantType1
| VariantType2
let branch_with_variant_and_annotation =
fun
| (VariantType1: test_foo) => true
| VariantType2 => false;
type intRange = {
from: option(string),
to_: option(string)
}
type optIntRange = option(intRange)
let optIntRangeOfIntRange =
fun
| ({from: None, to_: None}: intRange) => (None: optIntRange)
| {from, to_} => Some({from, to_});
================================================
FILE: test/patternMatching.t/run.t
================================================
Format basic
$ refmt --print re ./input.re > ./formatted.re
Print the formatted file
$ cat ./formatted.re
type point = {
x: int,
y: int,
};
let id = x => x;
type myVariant =
| TwoCombos(inner, inner)
| Short
| AlsoHasARecord(int, int, point)
and inner =
| Unused
| HeresTwoConstructorArguments(int, int);
let computeTuple = (a, b, c, d, e, f, g, h) => (
a + b,
c + d,
e + f,
g + h,
);
let res =
switch (TwoCombos(Unused, Unused)) {
| TwoCombos(
HeresTwoConstructorArguments(x, y),
HeresTwoConstructorArguments(a, b),
) => (
x,
y,
a,
b,
)
| TwoCombos(_, _) => (0, 0, 0, 0)
| Short
| AlsoHasARecord(300, _, _) => (
100000,
100000,
100000,
100000,
)
| AlsoHasARecord(firstItem, two, { x, y }) =>
computeTuple(
firstItem,
firstItem,
firstItem,
firstItem,
firstItem,
two,
two,
two,
)
};
/**
* Match bodies may include sequence expressions, but without the `{}`
* braces required.
*/
let res =
switch (TwoCombos(Unused, Unused)) {
| TwoCombos(
HeresTwoConstructorArguments(x, y),
HeresTwoConstructorArguments(a, b),
) =>
let ret = (x, y, a, b);
ret;
| TwoCombos(_, _) =>
/**
* See, no braces required - saves indentation as well!
*/
let ret = (0, 0, 0, 0);
ret;
| Short
| AlsoHasARecord(300, _, _) =>
/**
* And no final semicolon is required.
*/
let ret = (100000, 100000, 100000, 100000);
ret;
| AlsoHasARecord(firstItem, two, { x, y }) =>
computeTuple(
firstItem,
firstItem,
firstItem,
firstItem,
firstItem,
two,
two,
two,
)
};
/**
* Ensure that nested Pexp_functions are correctly wrapped in parens.
*
*/
let res =
switch (TwoCombos(Unused, Unused)) {
| TwoCombos(
HeresTwoConstructorArguments(x, y),
HeresTwoConstructorArguments(a, b),
) => (
fun
| Some(x) => x + 1
| None => 0
)
| TwoCombos(_, _) =>
let x = (
fun
| Some(x) => x + 1
| None => 0
);
x;
| Short
| AlsoHasARecord(300, _, _) =>
id(
fun
| Some(x) => x + 1
| None => 0,
)
| AlsoHasARecord(firstItem, two, { x, y }) =>
id(
fun
| Some(x) => x + 1
| None => 0,
)
};
/* test (), which is sugar for (()) */
switch (Some()) {
| Some () => 1
| _ => 2
};
switch (Some()) {
| Some () => 1
| _ => 2
};
switch (Some()) {
| Some () => 1
| _ => 2
};
switch (Some()) {
| Some () => 1
| _ => 2
};
type foo =
| Foo(unit);
switch (Foo()) {
| Foo () => 1
};
switch (Foo()) {
| Foo () => 1
};
switch (Foo()) {
| Foo () => 1
};
switch (Foo()) {
| Foo () => 1
};
switch () {
| () => 1
};
switch () {
| () => 1
};
switch () {
| () => 1
};
switch () {
| () => 1
};
switch (Some(1)) {
| Some(1) => 1
| None => 2
| _ => 3
};
let myInt = 100;
/* Numeric ranges are rejected by the type checker, but validly parsed so drop
* this in an annotation to test the parsing. */
[@something? 1 .. 2]
let rangeInt = 0;
let myChar = 'x';
let rangeChar =
switch (myChar) {
| 'a' .. 'b' => "a to b"
| 'b' .. 'z' => "b to z"
| c => "something else"
};
/* with parens around direct list pattern in constructor pattern */
switch (None) {
| Some([]) => ()
| Some([_]) when true => ()
| Some([x]) => ()
| Some([x, ...xs]) when true => ()
| Some([x, y, z]) => ()
| _ => ()
};
/* no parens around direct list pattern in constructor pattern (sugar) */
switch (None) {
| Some([]) => ()
| Some([_]) when true => ()
| Some([x]) => ()
| Some([x, ...xs]) when true => ()
| Some([x, y, z]) => ()
| _ => ()
};
/* with parens around direct array pattern in constructor pattern */
switch (None) {
| Some([||]) => "empty"
| Some([|_|]) when true => "one any"
| Some([|a|]) => "one"
| Some([|a, b|]) => "two"
| _ => "many"
};
/* no parens around direct array pattern in constructor pattern (sugar) */
switch (None) {
| Some([||]) => "empty"
| Some([|_|]) when true => "one any"
| Some([|a|]) => "one"
| Some([|a, b|]) => "two"
| _ => "many"
};
/* parens around direct record pattern in constructor pattern */
switch (None) {
| Some({ x }) when true => ()
| Some({ x, y }) => ()
| _ => ()
};
/* no parens around direct record pattern in constructor pattern (sugar) */
switch (None) {
| Some({ x }) when true => ()
| Some({ x, y }) => ()
| _ => ()
};
switch (None) {
| Some([|
someSuperLongString,
thisShouldBreakTheLine,
|]) =>
()
| _ => ()
};
switch (None) {
| Some((
someSuperLongString,
thisShouldBreakTheLine,
)) =>
()
| _ => ()
};
switch (None) {
| Some([
someSuperLongString,
thisShouldBreakTheLine,
]) =>
()
| Some([
someSuperLongString,
...es6ListSugarLikeSyntaxWhichIsSuperLong,
])
when true === true =>
()
| Some([
someSuperLongString,
...es6ListSugarLikeSyntaxWhichIsSuperLong,
]) =>
()
| _ => ()
};
type aOrB =
| A(int)
| B(int);
let ((nestedAnnotation: int): int) = 0;
let ((A(i) | B(i)): aOrB) = A(0);
type test_foo =
| VariantType1
| VariantType2;
let branch_with_variant_and_annotation =
fun
| (VariantType1: test_foo) => true
| VariantType2 => false;
type intRange = {
from: option(string),
to_: option(string),
};
type optIntRange = option(intRange);
let optIntRangeOfIntRange =
fun
| ({ from: None, to_: None }: intRange) => (
None: optIntRange
)
| { from, to_ } =>
Some({
from,
to_,
});
Type-check basics
$ ocamlc -c -pp 'refmt --print binary' -intf-suffix .rei -impl formatted.re
Format the formatted file back
$ refmt --print re ./formatted.re > ./formatted_back.re
Ensure idempotency: first format and second format are the same
$ diff formatted.re formatted_back.re
================================================
FILE: test/pervasive.t/input.mli
================================================
val ( = ) : 'a -> 'a -> bool
val ( <> ) : 'a -> 'a -> bool
val not : bool -> bool
================================================
FILE: test/pervasive.t/run.t
================================================
Format basic
$ refmt --print re ./input.mli > ./formatted.rei
Type-check basics
$ ocamlc -c -pp 'refmt --print binary' -intf-suffix .rei -intf formatted.rei
Format the formatted file back
$ refmt --print re ./formatted.rei > ./formatted_back.rei
Ensure idempotency: first format and second format are the same
$ diff formatted.rei formatted_back.rei
================================================
FILE: test/pexpFun.t/input.re
================================================
let x =
switch (x) {
| Bar =>
ReasonReact.UpdateWithSideEffects(
{...state, click: click + 1},
self => {
let _ = 1;
apply(bar);
},
"foo",
)
| Foo => ()
};
let x =
switch (x) {
| Bar =>
ReasonReact.UpdateWithSideEffects(
self => {
let _ = 1;
apply(bar);
},
)
| Foo => ()
};
Mod.Update(
(acc, curr) => {
let x = 1;
string_of_int(curr);
},
"",
lst,
);
Mod.Update(
(acc, curr): string => {
let x = 1;
string_of_int(curr);
},
"",
lst,
);
Mod.Update(
[@foo] [@bar]
(acc, curr) => {
let x = 1;
string_of_int(curr);
},
"",
lst,
);
Mod.Update(
[@foo] [@bar]
(curr) => string_of_int(curr),
"",
lst,
);
Mod.Update(
[@foo] [@bar] [@baz] [@something] [@do] curr => string_of_int(curr),
"",
lst,
);
Mod.Update(
(acc, curr, lkdjf, lskdfj, sdfljk, slkdjf, skdjf, sdlkfj): string => {
let x = 1;
string_of_int(curr);
},
"",
lst,
);
Mod.Update((acc, curr) => string_of_int(curr), "", lst);
let foo = () => {
x(() => ("foo": string));
};
x(() => ("foo": string));
let x = {
let y = () => ("foo": string);
()
};
================================================
FILE: test/pexpFun.t/run.t
================================================
Format function expressipns (pexpFun)
$ refmt ./input.re
let x =
switch (x) {
| Bar =>
ReasonReact.UpdateWithSideEffects(
{
...state,
click: click + 1,
},
self => {
let _ = 1;
apply(bar);
},
"foo",
)
| Foo => ()
};
let x =
switch (x) {
| Bar =>
ReasonReact.UpdateWithSideEffects(
self => {
let _ = 1;
apply(bar);
},
)
| Foo => ()
};
Mod.Update(
(acc, curr) => {
let x = 1;
string_of_int(curr);
},
"",
lst,
);
Mod.Update(
(acc, curr): string => {
let x = 1;
string_of_int(curr);
},
"",
lst,
);
Mod.Update(
[@foo] [@bar] (acc, curr) => {
let x = 1;
string_of_int(curr);
},
"",
lst,
);
Mod.Update(
[@foo] [@bar] curr => string_of_int(curr),
"",
lst,
);
Mod.Update(
[@foo] [@bar] [@baz] [@something] [@do] curr =>
string_of_int(curr),
"",
lst,
);
Mod.Update(
(
acc,
curr,
lkdjf,
lskdfj,
sdfljk,
slkdjf,
skdjf,
sdlkfj,
): string => {
let x = 1;
string_of_int(curr);
},
"",
lst,
);
Mod.Update(
(acc, curr) => string_of_int(curr),
"",
lst,
);
let foo = () => {
x((): string => "foo");
};
x((): string => "foo");
let x = {
let y = (): string => "foo";
();
};
================================================
FILE: test/pipeFirst.t/input.re
================================================
foo |. f |. g |. h;
bar->f->g->h;
foo(g)->f(a, b)->g(c, d);
foo->f();
compilation
->Plugin.buildAssets
->Js.Json.stringify
->Node.Fs.writeFileAsUtf8Sync(_, path);
foo
->someLongIdentifier
->otherLongIdentifierWithArgs(a, b, c)
->longIdentWithVeryLongArgs(aaaaaaaaaaaaaaaaaaaaa, bbbbbbbbbbbbbbbb, ccccccccccccc);
/* with comments */
compilation
/* first */
->Plugin.buildAssets /* first trail */
/* second */
->Js.Json.stringify /* second trail */
/* last */
->Node.Fs.writeFileAsUtf8Sync(_, path); /* last trail */
foo->bar->baz >>= monadicFunction |> bind;
compilation
->Plugin.buildAssets
->Js.Json.stringify
|> Cohttp_lwt_body.to_string
>|= (
body =>
Printf.sprintf(
"okokok",
uri,
meth,
headers,
body,
)
)
>>= (
body =>
Server.respond_string(
~status,
~body,
(),
)
);
x + y + foo->bar->baz;
x + y * foo->bar->baz;
x && y || foo->bar->baz;
x < foo->bar->baz;
foo !== bar->baz;
x |> y >>= foo->bar->baz;
let m = f => foo->bar->f;
obj##x->foo->bar;
(event->target)[0];
event->target[0];
(event->target)##value;
event->target##value;
event->target##value[0];
event |. target##value[0];
event->target(foo);
event->(target(foo));
(event->target)(foo);
event |. target(foo);
foo->bar := baz;
foo->bar === baz;
event->target##value(foo);
event->target##(value(foo));
(foo^)->bar;
(location##streets).foo[1];
(event->target^)##value;
event->target^ #= value;
foo->f(. a, b);
foo->f(. a, b)->g(. c, d);
foo->([@attr] f(. a, b))->([@attr2] f(. a, b));
foo->f(.);
foo->f(.)->g(.);
foo->([@attr] f(.))->([@attr] g(.));
("some-string" ++ "another")->more;
(-1)->foo;
-1->foo;
!foo->bar;
(!foo)->bar;
a->(b##c);
(a->b)##c;
(switch (saveStatus) {
| Pristine => ""
| Saved => "Saved"
| Saving => "Saving"
| Unsaved => "Unsaved"
})
->str;
<div>
(switch (saveStatus) {
| Pristine => ""
| Saved => "Saved"
| Saving => "Saving"
| Unsaved => "Unsaved"
})
->str
</div>;
blocks->(blocks => {"blocks": blocks});
<div> blocks->(blocks => {"blocks": blocks}) </div>;
(state.title == "" ? "untitled" : state.title)->str;
<title> ((state.title == "" ? "untitled" : state.title)->str) </title>;
ReasonReact.Router.watchUrl(url => Route.urlToRoute(url)->ChangeView->(self.send));
ReasonReact.Router.watchUrl(url => Route.urlToRoute(url)->ChangeView->self.send);
window->Webapi.Dom.Window.open_(~url, ~name="authWindow", ~features=params);
window->Webapi.Dom.Window.open_(~url, ~name="authWindow", () => { let x = 1; let y = 2; x + y; });
reactClass
->setNavigationOptions(
NavigationOptions.t(~title="Title", ~gesturesEnabled=false, ()),
);
Foo.Bar.reactClass
->setNavigationOptions(
NavigationOptions.t(~title="Title", ~gesturesEnabled=false, ()),
);
foo##bar
->setNavigationOptions(
NavigationOptions.t(~title="Title", ~gesturesEnabled=false, ()),
);
<div> {items->Belt.Array.map(ReasonReact.string)->ReasonReact.array} </div>;
a->(b->c);
<div> (T.t("value") |. ReasonReact.string) </div>;
<div> {url->a(b, _)} </div>;
<div> {url->a(b, _)->a(b, _)} </div>;
foo->Option.map(fn(_, arg));
================================================
FILE: test/pipeFirst.t/run.t
================================================
Format pipe first (->)
$ refmt ./input.re
foo->f->g->h;
bar->f->g->h;
foo(g)->f(a, b)->g(c, d);
foo->f();
compilation
->Plugin.buildAssets
->Js.Json.stringify
->Node.Fs.writeFileAsUtf8Sync(_, path);
foo
->someLongIdentifier
->otherLongIdentifierWithArgs(a, b, c)
->longIdentWithVeryLongArgs(
aaaaaaaaaaaaaaaaaaaaa,
bbbbbbbbbbbbbbbb,
ccccccccccccc,
);
/* with comments */
compilation
/* first */
->Plugin.buildAssets /* first trail */
/* second */
->Js.Json.stringify /* second trail */
/* last */
->Node.Fs.writeFileAsUtf8Sync(_, path); /* last trail */
foo->bar->baz >>= monadicFunction |> bind;
compilation
->Plugin.buildAssets
->Js.Json.stringify
|> Cohttp_lwt_body.to_string
>|= (
body =>
Printf.sprintf(
"okokok",
uri,
meth,
headers,
body,
)
)
>>= (
body =>
Server.respond_string(~status, ~body, ())
);
x + y + foo->bar->baz;
x + y * foo->bar->baz;
x && y || foo->bar->baz;
x < foo->bar->baz;
foo !== bar->baz;
x |> y >>= foo->bar->baz;
let m = f => foo->bar->f;
obj##x->foo->bar;
event->target[0];
event->target[0];
event->target##value;
event->target##value;
event->target##value[0];
event->(target##value[0]);
event->target(foo);
event->(target(foo));
event->target(foo);
event->(target(foo));
foo->bar := baz;
foo->bar === baz;
event->target##value(foo);
event->target##(value(foo));
(foo^)->bar;
location##streets.foo[1];
(event->target^)##value;
event->target^ #= value;
foo->f(. a, b);
foo->f(. a, b)->g(. c, d);
foo->([@attr] f(. a, b))->([@attr2] f(. a, b));
foo->f(.);
foo->f(.)->g(.);
foo->([@attr] f(.))->([@attr] g(.));
("some-string" ++ "another")->more;
(-1)->foo;
- 1->foo;
!foo->bar;
(!foo)->bar;
a->(b##c);
a->b##c;
(
switch (saveStatus) {
| Pristine => ""
| Saved => "Saved"
| Saving => "Saving"
| Unsaved => "Unsaved"
}
)
->str;
<div>
(
switch (saveStatus) {
| Pristine => ""
| Saved => "Saved"
| Saving => "Saving"
| Unsaved => "Unsaved"
}
)
->str
</div>;
blocks->(blocks => { "blocks": blocks });
<div>
blocks->(blocks => { "blocks": blocks })
</div>;
(state.title == "" ? "untitled" : state.title)
->str;
<title>
(state.title == "" ? "untitled" : state.title)
->str
</title>;
ReasonReact.Router.watchUrl(url =>
Route.urlToRoute(url)->ChangeView->(self.send)
);
ReasonReact.Router.watchUrl(url =>
Route.urlToRoute(url)->ChangeView->self.send
);
window->Webapi.Dom.Window.open_(
~url,
~name="authWindow",
~features=params,
);
window->Webapi.Dom.Window.open_(
~url,
~name="authWindow",
() => {
let x = 1;
let y = 2;
x + y;
},
);
reactClass->setNavigationOptions(
NavigationOptions.t(
~title="Title",
~gesturesEnabled=false,
(),
),
);
Foo.Bar.reactClass->setNavigationOptions(
NavigationOptions.t(
~title="Title",
~gesturesEnabled=false,
(),
),
);
foo##bar
->setNavigationOptions(
NavigationOptions.t(
~title="Title",
~gesturesEnabled=false,
(),
),
);
<div>
{items
->Belt.Array.map(ReasonReact.string)
->ReasonReact.array}
</div>;
a->(b->c);
<div> {T.t("value")->ReasonReact.string} </div>;
<div> {url->a(b, _)} </div>;
<div> {url->a(b, _)->a(b, _)} </div>;
foo->Option.map(fn(_, arg));
================================================
FILE: test/polymorphism.t/input.re
================================================
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
let run = fun () => {
TestUtils.printSection("Polymorphism");
};
type myType('a) = list('a);
type myTwoParamType('a,'b) = ('a, 'b);
type myTupleType = (int, int);
type myPolymorphicTupleType('a) = ('a, 'a);
type extensible('a) = 'a
constraint 'a = [ | `Base(int)];
type intListTranformer = (list(int)) => list(int);
type x = list (int, string);
module HoldsAType = {
type hasPrime('a,'b,'c) = Hashtbl.t (list('a),list('b));
};
type myType2 = (myTwoParamType(myType((int) => int), int)) => int;
/* Confusing because => looks like part
of the return type signature. */
let myFunc (a:(int)=>int, b:(int)=>int) :myType(int) =
[a(20) + b(30)];
let myFunc (a:(int)=>int, b:(int)=>int) : ((myType(int)) => myType(int)) =
fun(lst) => lst;
let certainlyRequiresWrapping:
(option((Mod.handler(p,re), Mod.Types.handler)),
option((Mod.touch(props,(props, state),resource), (list(Mod.t), list(Mod.t)))),
list(Mod.update(props,(props, state),resource))) =>
list(Mod.update(props,(props, state),resource)) = ();
/* Because of the confusion in the last two examples, I believe we should
switch back to the `=` based syntax.
let add a b = a + b;
Pexp_function printing:
Decide on either:
let add Some (Hearts n) = n + n
| add Some (Diamonds n) = 0
| add Some (Spades n) = 0
| add None = 0
| _ = 0
Or:
let add = x => match x with
| Some (Hearts n) => n + n
| Some (Diamonds n) => 0
| Some (Spades n) => 0
| None => 0
| _ => 0
let add =
| Some (Hearts n) => n + n
| Some (Diamonds n) => 0
| Some (Spades n) => 0
| None => 0
| _ => 0
let myFunc = (a:int) (b:int) => a + b; */
/* Fringe features */
/*
/* This parses, but doesn't type check */
module TryExtendingType = {type t = Hello of string;};
type TryExtendingType.t += LookANewExtension of string;
*/
"end";
================================================
FILE: test/polymorphism.t/run.t
================================================
Format polymoprhism
$ refmt ./input.re
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
let run = () => {
TestUtils.printSection("Polymorphism");
};
type myType('a) = list('a);
type myTwoParamType('a, 'b) = ('a, 'b);
type myTupleType = (int, int);
type myPolymorphicTupleType('a) = ('a, 'a);
type extensible('a) = 'a
constraint 'a = [ | `Base(int)];
type intListTranformer =
list(int) => list(int);
type x = list(int, string);
module HoldsAType = {
type hasPrime('a, 'b, 'c) =
Hashtbl.t(list('a), list('b));
};
type myType2 =
myTwoParamType(myType(int => int), int) =>
int;
/* Confusing because => looks like part
of the return type signature. */
let myFunc =
(a: int => int, b: int => int): myType(int) => [
a(20) + b(30),
];
let myFunc =
(a: int => int, b: int => int)
: (myType(int) => myType(int)) =>
lst => lst;
let certainlyRequiresWrapping:
(
option(
(Mod.handler(p, re), Mod.Types.handler),
),
option(
(
Mod.touch(
props,
(props, state),
resource,
),
(list(Mod.t), list(Mod.t)),
),
),
list(
Mod.update(
props,
(props, state),
resource,
),
)
) =>
list(
Mod.update(
props,
(props, state),
resource,
),
) =
();
/* Because of the confusion in the last two examples, I believe we should
switch back to the `=` based syntax.
let add a b = a + b;
Pexp_function printing:
Decide on either:
let add Some (Hearts n) = n + n
| add Some (Diamonds n) = 0
| add Some (Spades n) = 0
| add None = 0
| _ = 0
Or:
let add = x => match x with
| Some (Hearts n) => n + n
| Some (Diamonds n) => 0
| Some (Spades n) => 0
| None => 0
| _ => 0
let add =
| Some (Hearts n) => n + n
| Some (Diamonds n) => 0
| Some (Spades n) => 0
| None => 0
| _ => 0
let myFunc = (a:int) (b:int) => a + b; */
/* Fringe features */
/*
/* This parses, but doesn't type check */
module TryExtendingType = {type t = Hello of string;};
type TryExtendingType.t += LookANewExtension of string;
*/
"end";
================================================
FILE: test/print-width-env.t
================================================
Create a file with a long line
$ cat >test.re <<EOF
> let initialState = uiStateFromValidated(~ownership=RemoteData.NotAsked, ~limits=initialLimits, SiteAuditSettings.default);
> EOF
Set the print width to 120 characters via env "REFMT_PRINT_WIDTH"
$ REFMT_PRINT_WIDTH=120 refmt test.re
let initialState =
uiStateFromValidated(~ownership=RemoteData.NotAsked, ~limits=initialLimits, SiteAuditSettings.default);
Set the print width to 80 characters via env "REFMT_PRINT_WIDTH"
$ REFMT_PRINT_WIDTH=80 refmt test.re
let initialState =
uiStateFromValidated(
~ownership=RemoteData.NotAsked,
~limits=initialLimits,
SiteAuditSettings.default,
);
================================================
FILE: test/raw-identifiers.t/input.re
================================================
let \#let = 2;
let \#let = \#let
and \#and = \#let;
/* labeled arguments */
let \#let = (~\#let) => {
\#let;
};
let \#let = (~\#let: \#let = \#let) => {
\#let;
};
/* Types */
type \#type = \#type;
module type \#module = \#module;
class \#class = \#class;
class type \#class = \#class;
type x = [ | `\#module ]
type y = [ | \#module ]
let x = `\#module
external \#external: unit => unit = "external";
type \#rec = {
\#type: \#type,
\#module: module_
};
let \#rec = {
\#type: \#type,
\#module: module_
}
let true = x => x;
let \#true = x => x;
================================================
FILE: test/raw-identifiers.t/run.t
================================================
Test raw identifiers in Reason syntax
$ refmt ./input.re | tee input2.re
let \#let = 2;
let \#let = \#let
and \#and = \#let;
/* labeled arguments */
let \#let = (~\#let) => {
\#let;
};
let \#let = (~\#let: \#let=\#let) => {
\#let;
};
/* Types */
type \#type = \#type;
module type \#module = \#module;
class \#class = class \#class;
class type \#class = \#class;
type x = [ | `\#module];
type y = [ \#module];
let x = `\#module;
external \#external: unit => unit = "external";
type \#rec = {
\#type,
\#module: module_,
};
let \#rec = {
\#type,
\#module: module_,
};
let true = x => x;
let \#true = x => x;
Check idempotency
$ refmt ./input2.re > out.re
================================================
FILE: test/reasonComments-rei.t/input.rei
================================================
module JustString : {
include Map.S; /* Comment eol include */
};
================================================
FILE: test/reasonComments-rei.t/run.t
================================================
Format basic
$ refmt --print re ./input.rei > ./formatted.rei
Type-check basics
$ ocamlc -c -pp 'refmt --print binary' -intf-suffix .rei -intf formatted.rei
Format the formatted file back
$ refmt --print re ./formatted.rei > ./formatted_back.rei
Ensure idempotency: first format and second format are the same
$ diff formatted.rei formatted_back.rei
================================================
FILE: test/rtopIntegration.t
================================================
Context: https://github.com/reasonml/reason/pull/674
We can't directly call `rtop -stdin` because it circumvents what we're trying to
test. See rtop.sh for the reason. We want to make sure utop's reason
integration is legit,
`utop -stdin` wouldn't work because it somehow processes the code before
invoking the reason plugin, so `echo someReasonCode | utop -stdin` would
always error.
Given the above, we're gonna test that utop integration works by piping code
into it and asserting the existence of some output.
$ echo "let f = a => a;" | rtop 2>&1 | grep -o "let f: 'a => 'a = <fun>;"
let f: 'a => 'a = <fun>;
$ echo "let f = (a) => 1 + \"hi\";" | rtop 2>&1 | grep -o "has type"
has type
================================================
FILE: test/sequences.t/input.re
================================================
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
/**
* Testing Sequences.
*/
let result = {
let twenty = 20;
let result = twenty;
result;
};
/* Final semicolon is not required */
let result = {
let twenty = result;
twenty
};
let anInt = result + 20;
let twenty = 20;
/**
* Each of these are a sequence with a single item - they will be
* printed in reduced form because sequences are a *parse* time construct.
* To ensure these are parsed correctly, adding to an integer.
*/
let result = 0 + {twenty};
let result = 0 + {twenty;};
let result = 0 + twenty;
let unitValue = ();
/* While loops/for loops merely accept a "simple expression" (which means
* it is either a simple token or balanced with parens/braces). However,
* the formatter ensures that the bodies are printed in "sequence" form even if
* it's not required.
*/
while (false) unitValue;
while (false) {
print_string("test")
};
while (false) {
print_string("test");
};
type myRecord = {
number: int
};
let x = {number:20};
let number = 20;
/*
* The (mild) consequence of not requiring a final semi in a sequence,
* is that we can no longer "pun" a single field record (which would)
* be very rare anyways.
*/
let cannotPunASingleFieldRecord = {number: number};
let fourty = 20 + cannotPunASingleFieldRecord.number;
let thisIsASequenceNotPunedRecord = {number};
let fourty = 20 + thisIsASequenceNotPunedRecord;
type recordType = {a: int, b: int, c: int};
let a = 0;
let b = 0;
let c = 0;
/* All of these will be printed as punned because they have more than one field. */
let firstFieldPunned = {
a: a,
b,
c: c
};
let sndFieldPunned = {
a,
b: b,
c: c
};
let thirdFieldPunned = {
a: a,
b: b,
c
};
let singlePunAcceptedIfExtended = {...firstFieldPunned, a};
/* non-punned */
let firstFieldNonPun = {
a: [@with_attribute] a,
b,
c
};
let secondFieldNonPun = {
a,
b: [@with_attribute] b,
c
};
let thirdFieldNonPun = {
a,
b,
c: [@with_attribute] c,
};
================================================
FILE: test/sequences.t/run.t
================================================
Format basic
$ refmt --print re ./input.re > ./formatted.re
Print the formatted file
$ cat ./formatted.re
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
/**
* Testing Sequences.
*/
let result = {
let twenty = 20;
let result = twenty;
result;
};
/* Final semicolon is not required */
let result = {
let twenty = result;
twenty;
};
let anInt = result + 20;
let twenty = 20;
/**
* Each of these are a sequence with a single item - they will be
* printed in reduced form because sequences are a *parse* time construct.
* To ensure these are parsed correctly, adding to an integer.
*/
let result =
0
+ {
twenty;
};
let result =
0
+ {
twenty;
};
let result = 0 + twenty;
let unitValue = ();
/* While loops/for loops merely accept a "simple expression" (which means
* it is either a simple token or balanced with parens/braces). However,
* the formatter ensures that the bodies are printed in "sequence" form even if
* it's not required.
*/
while (false) {
unitValue;
};
while (false) {
print_string("test");
};
while (false) {
print_string("test");
};
type myRecord = {number: int};
let x = { number: 20 };
let number = 20;
/*
* The (mild) consequence of not requiring a final semi in a sequence,
* is that we can no longer "pun" a single field record (which would)
* be very rare anyways.
*/
let cannotPunASingleFieldRecord = {
number: number,
};
let fourty =
20 + cannotPunASingleFieldRecord.number;
let thisIsASequenceNotPunedRecord = {
number;
};
let fourty = 20 + thisIsASequenceNotPunedRecord;
type recordType = {
a: int,
b: int,
c: int,
};
let a = 0;
let b = 0;
let c = 0;
/* All of these will be printed as punned because they have more than one field. */
let firstFieldPunned = {
a,
b,
c,
};
let sndFieldPunned = {
a,
b,
c,
};
let thirdFieldPunned = {
a,
b,
c,
};
let singlePunAcceptedIfExtended = {
...firstFieldPunned,
a,
};
/* non-punned */
let firstFieldNonPun = {
a: [@with_attribute] a,
b,
c,
};
let secondFieldNonPun = {
a,
b: [@with_attribute] b,
c,
};
let thirdFieldNonPun = {
a,
b,
c: [@with_attribute] c,
};
Type-check basics
$ ocamlc -c -pp 'refmt --print binary' -intf-suffix .rei -impl formatted.re
Format the formatted file back
$ refmt --print re ./formatted.re > ./formatted_back.re
Ensure idempotency: first format and second format are the same
$ diff formatted.re formatted_back.re
================================================
FILE: test/sharpop.t/input.re
================================================
foo#=bar[0];
foo##bar[0] = 3;
foo##bar[0]##baz[1] = 3;
foo##bar[0]##baz[1];
foo##bar#=bar[0];
foo##bar##baz #= bar##baz[0];
foo[bar + 1];
foo.[bar + 1];
foo.{bar + 1};
foo.[bar + 1] = 1;
foo.{bar + 1} = 1;
foo[bar + 1] = 1;
================================================
FILE: test/sharpop.t/run.t
================================================
Format sharp operator
$ refmt ./input.re
foo #= bar[0];
foo##bar[0] = 3;
foo##bar[0]##baz[1] = 3;
foo##bar[0]##baz[1];
foo##bar #= bar[0];
foo##bar##baz #= bar##baz[0];
foo[bar + 1];
foo.[bar + 1];
foo.{bar + 1};
foo.[bar + 1] = 1;
foo.{bar + 1} = 1;
foo[bar + 1] = 1;
================================================
FILE: test/singleLineCommentEof.t/input.re
================================================
// let x = 1
================================================
FILE: test/singleLineCommentEof.t/run.t
================================================
Format single line comment at the end of the file
$ refmt ./input.re
// let x = 1
================================================
FILE: test/testUtils.t/input.re
================================================
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
let printSection(s) {
print_string("\n");
print_string(s);
print_string("\n---------------------\n");
};
let printLn(s) = print_string(s ++ "\n");
================================================
FILE: test/testUtils.t/run.t
================================================
Format test utils
$ refmt ./input.re
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
let printSection = s => {
print_string("\n");
print_string(s);
print_string("\n---------------------\n");
};
let printLn = s => print_string(s ++ "\n");
================================================
FILE: test/trailing.t/input.re
================================================
let x = {
"obj": obj,
};
let x = {
"key",
"keyTwo",
};
let x = {
...x,
"key",
};
let x = {
...x,
"key",
"keyTwo",
};
type t = {.
"x": int,
};
type t('a) = {..
"x": int,
} as 'a;
type t = {.
"x": (int, int),
};
type t('a) = {..
"x": (int, int),
} as 'a;
let x = {
"obj": 0,
};
let x = {
"key": 0,
"keyTwo": 1,
};
let x = {
...x,
"key": 0,
};
let x = {
...x,
"key": 0,
"keyTwo": 1,
};
type t = {.
"x": int,
};
type t('a) = {..
"x": int,
} as 'a;
type t = {.
"x": (int, int),
};
type t('a) = {..
"x": (int, int),
} as 'a;
================================================
FILE: test/trailing.t/run.t
================================================
Format trailing
$ refmt ./input.re
let x = { "obj": obj };
let x = {
"key": key,
"keyTwo": keyTwo,
};
let x = {
...x,
"key": key,
};
let x = {
...x,
"key": key,
"keyTwo": keyTwo,
};
type t = {. "x": int };
type t('a) = {.. "x": int } as 'a;
type t = {. "x": (int, int) };
type t('a) = {.. "x": (int, int) } as 'a;
let x = { "obj": 0 };
let x = {
"key": 0,
"keyTwo": 1,
};
let x = {
...x,
"key": 0,
};
let x = {
...x,
"key": 0,
"keyTwo": 1,
};
type t = {. "x": int };
type t('a) = {.. "x": int } as 'a;
type t = {. "x": (int, int) };
type t('a) = {.. "x": (int, int) } as 'a;
================================================
FILE: test/trailingSpaces.t/input.re
================================================
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
module M = Something.Create {
type resource1 = MyModule.MySubmodule.t;
type resource2 = MyModule.MySubmodule.t;
};
================================================
FILE: test/trailingSpaces.t/run.t
================================================
Format trailing spaces
$ refmt ./input.re
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
module M =
Something.Create({
type resource1 = MyModule.MySubmodule.t;
type resource2 = MyModule.MySubmodule.t;
});
================================================
FILE: test/type-constraint-in-body.t/input.ml
================================================
let f x = (x : int)
let f x = (x : Foo.bar)
let f x y = (x + y : int)
let f x = (x : int -> int)
================================================
FILE: test/type-constraint-in-body.t/run.t
================================================
$ refmt ./input.ml | tee formatted.re
let f = (x): int => x;
let f = (x): Foo.bar => x;
let f = (x, y): int => x + y;
let f = (x): (int => int) => x;
$ refmt ./formatted.re | tee formatted_back.re
let f = (x): int => x;
let f = (x): Foo.bar => x;
let f = (x, y): int => x + y;
let f = (x): (int => int) => x;
$ diff formatted.re formatted_back.re
================================================
FILE: test/type-pipeFirst.t/input.re
================================================
let (|.) = (x, y) => x + y;
let a = 1;
let b = 2;
let c = 3;
/* parses as 10 < (a->b->c) */
let t1: bool = 10 < a->b->c;
type coordinate = {x: int, y: int};
let coord = {x: 1, y: 1};
/* parses as (coord.x)->a->b->c */
let t2: int = coord.x->a->b->c;
let (|.) = (x, y) => x || y;
let a = true;
let b = false;
let c = true;
/* parses as !(a->b->c) */
let t3: bool = !a->b->c;
/* parse pipe first with underscore application correct */
let doStuff = (a: int, b: int, c: int): int => {
a + 2 * b + 3 * c;
};
let (|.) = (a, f) => f(a);
let t4: int = 5->doStuff(1, _, 7);
let t5: int = 5->doStuff(1, _, 7)->doStuff(1, _, 7);
module Foo = {
let createElement = (~children, ()) =>
List.hd(children) ++ "test";
let map = (xs, f) => List.map(f, xs);
let plusOne = x => x + 1;
let toString = lst =>
List.fold_left(
(acc, curr) =>
acc ++ (string_of_int(curr)),
"",
lst
);
};
let items = [1, 2, 3];
let t6: string =
<Foo> {items->Foo.map(Foo.plusOne)->Foo.toString} </Foo>;
type saveStatus =
| Pristine
| Saved
| Saving
| Unsaved;
let saveStatus = Pristine;
let t7: string =
<Foo>
{
(
switch (saveStatus) {
| Pristine => [0]
| Saved => [1]
| Saving => [2]
| Unsaved => [3]
}
)
->Foo.map(Foo.plusOne)
->Foo.toString
}
</Foo>;
let genItems = (f) => List.map(f, items);
let t8: string =
<Foo>
{genItems(Foo.plusOne)->Foo.toString}
</Foo>;
let blocks = [1, 2, 3];
let t9: string =
<Foo>
blocks->(b => Foo.toString(b))
</Foo>;
let foo = (xs) => List.concat([xs, xs]);
let t10: string =
<Foo>
{blocks->foo->Foo.map(Foo.plusOne)->Foo.toString}
</Foo>;
let t11: string =
<Foo>
{blocks->foo->Foo.map(Foo.plusOne)->Foo.map(Foo.plusOne)->Foo.toString}
</Foo>;
let title = "los pilares de la tierra";
let t12: string =
<Foo>(title === "" ? [1, 2, 3]: blocks)->Foo.toString</Foo>
type change =
| Change(list(int));
type this = {
send: change => string
};
let change = x => Change(x);
let self = {
send: x =>
switch (x) {
| Change(xs) => Foo.toString(xs)
},
};
let urlToRoute = (x) => [x, x, x];
let t13: string = urlToRoute(1)->change->(self.send);
module FooLabeled = {
let createElement = (~children, ()) =>
List.hd(children) ++ "test";
let map = (xs, ~f) => List.map(f, xs);
let plusOne = x => x + 1;
let toString = lst =>
List.fold_left(
(acc, curr) =>
acc ++ (string_of_int(curr)),
"",
lst
);
};
let t14: string =
<FooLabeled> {items->FooLabeled.map(~f=FooLabeled.plusOne)->FooLabeled.toString} </FooLabeled>;
let c = (a, b) => a + b;
let a = 1;
let b = 2;
let t: int = a->(b->c);
module Div = {
let createElement = (~children, ()) =>
List.hd(children) ++ "test";
};
let url = "reason";
let suffix = ".com";
let parse = (a, b) => a ++ b;
let t15: string =
<Div> {url->parse(suffix, _)} </Div>;
================================================
FILE: test/type-pipeFirst.t/run.t
================================================
Format basic
$ refmt --print re ./input.re > ./formatted.re
Print the formatted file
$ cat ./formatted.re
let (|.) = (x, y) => x + y;
let a = 1;
let b = 2;
let c = 3;
/* parses as 10 < (a->b->c) */
let t1: bool = 10 < a->b->c;
type coordinate = {
x: int,
y: int,
};
let coord = {
x: 1,
y: 1,
};
/* parses as (coord.x)->a->b->c */
let t2: int = coord.x->a->b->c;
let (|.) = (x, y) => x || y;
let a = true;
let b = false;
let c = true;
/* parses as !(a->b->c) */
let t3: bool = !a->b->c;
/* parse pipe first with underscore application correct */
let doStuff = (a: int, b: int, c: int): int => {
a + 2 * b + 3 * c;
};
let (|.) = (a, f) => f(a);
let t4: int = 5->doStuff(1, _, 7);
let t5: int =
5->doStuff(1, _, 7)->doStuff(1, _, 7);
module Foo = {
let createElement = (~children, ()) =>
List.hd(children) ++ "test";
let map = (xs, f) => List.map(f, xs);
let plusOne = x => x + 1;
let toString = lst =>
List.fold_left(
(acc, curr) =>
acc ++ string_of_int(curr),
"",
lst,
);
};
let items = [1, 2, 3];
let t6: string =
<Foo>
{items->Foo.map(Foo.plusOne)->Foo.toString}
</Foo>;
type saveStatus =
| Pristine
| Saved
| Saving
| Unsaved;
let saveStatus = Pristine;
let t7: string =
<Foo>
{(
switch (saveStatus) {
| Pristine => [0]
| Saved => [1]
| Saving => [2]
| Unsaved => [3]
}
)
->Foo.map(Foo.plusOne)
->Foo.toString}
</Foo>;
let genItems = f => List.map(f, items);
let t8: string =
<Foo>
{genItems(Foo.plusOne)->Foo.toString}
</Foo>;
let blocks = [1, 2, 3];
let t9: string =
<Foo> blocks->(b => Foo.toString(b)) </Foo>;
let foo = xs => List.concat([xs, xs]);
let t10: string =
<Foo>
{blocks
->foo
->Foo.map(Foo.plusOne)
->Foo.toString}
</Foo>;
let t11: string =
<Foo>
{blocks
->foo
->Foo.map(Foo.plusOne)
->Foo.map(Foo.plusOne)
->Foo.toString}
</Foo>;
let title = "los pilares de la tierra";
let t12: string =
<Foo>
(title === "" ? [1, 2, 3] : blocks)
->Foo.toString
</Foo>;
type change =
| Change(list(int));
type this = {send: change => string};
let change = x => Change(x);
let self = {
send: x =>
switch (x) {
| Change(xs) => Foo.toString(xs)
},
};
let urlToRoute = x => [x, x, x];
let t13: string =
urlToRoute(1)->change->(self.send);
module FooLabeled = {
let createElement = (~children, ()) =>
List.hd(children) ++ "test";
let map = (xs, ~f) => List.map(f, xs);
let plusOne = x => x + 1;
let toString = lst =>
List.fold_left(
(acc, curr) =>
acc ++ string_of_int(curr),
"",
lst,
);
};
let t14: string =
<FooLabeled>
{items
->FooLabeled.map(~f=FooLabeled.plusOne)
->FooLabeled.toString}
</FooLabeled>;
let c = (a, b) => a + b;
let a = 1;
let b = 2;
let t: int = a->(b->c);
module Div = {
let createElement = (~children, ()) =>
List.hd(children) ++ "test";
};
let url = "reason";
let suffix = ".com";
let parse = (a, b) => a ++ b;
let t15: string =
<Div> {url->parse(suffix, _)} </Div>;
Type-check basics
$ ocamlc -c -pp 'refmt --print binary' -intf-suffix .rei -impl formatted.re
Format the formatted file back
$ refmt --print re ./formatted.re > ./formatted_back.re
Ensure idempotency: first format and second format are the same
$ diff formatted.re formatted_back.re
================================================
FILE: test/typeDeclarations.t/input.re
================================================
/* === test wrapping for arrows === */
type foo = option((int => int));
type foo = option((int => (int => int)));
type foo = option(((int => int) => int));
type foo = option(((int, int) => int));
/* tuple */
type foo = option(((int => int), (int => int)));
type foo = option(((int => int), string));
type foo = option((string, (int => int), string));
type foo = option((string, (int => int)));
/* other preceeding/trailing */
type foo = option((int => int), (int => int));
type foo = option((int => int), string);
type foo = option(string, (int => int), string);
type foo = option(string, (int => int));
/* preceeding/trailing, more args */
type foo = option((int => string => int), (int => string => int));
type foo = option((int => string => int), string);
type foo = option(string, (int => string => int), string);
type foo = option(string, (int => string => int));
/* others */
type foo = option(string, option(int => int), string);
type foo = option(string, option(option(option(int) => int)), string);
type foo = option(string, option([@foo]option(option(int) => int)), string);
/* with attributes */
type foo = option([@foo]([@bar] int => [@baz] int));
type foo = option([@foo]((([@bar] int) => [@baz] int)));
type foo = option((int => [@foo](int => int)));
type foo = option(([@foo](int => int) => int));
type foo = option(([@foo](int, int) => int));
/* tuple */
type foo = option([@foo]([@bar](int => int), [@baz](int => int)));
type foo = option([@foo]([@bar](int => int), [@baz] string));
type foo = option([@foo]([@bar]string, [@baz](int => int), [@qux]string));
type foo = option((string, [@foo](int => int)));
/* other preceeding/trailing */
type foo = option([@foo](int => int), [@bar](int => int));
type foo = option([@foo](int => int), [@bar]string);
type foo = option([@foo]string, [@bar](int => int), [@baz]string);
type foo = option([@foo]string, [@bar](int => int));
/* preceeding/trailing, more args */
type foo = option([@foo](int => string => int), [@bar](int => string => int));
type foo = option([@foo](int => string => int), [@bar]string);
type foo = option([@foo]string, [@bar](int => string => int), [@baz]string);
type foo = option([@foo]string, [@bar](int => string => int));
/* === end test wrapping for arrows === */
/* https://github.com/facebook/reason/issues/2073 */
type a = array({. "someStringKeyThatCausesLineToBreak": string });
/* Inline type record non punned field */
type b = {
punned: [@with_attribute] punned
};
/* Breakline record non punned field */
type c = {
a: string,
b: string,
punned: [@with_attribute] punned
};
type%x foo = int;
type%x foo += Int;
================================================
FILE: test/typeDeclarations.t/run.t
================================================
Format type declarations
$ refmt ./input.re
/* === test wrapping for arrows === */
type foo = option(int => int);
type foo = option((int, int) => int);
type foo = option((int => int) => int);
type foo = option((int, int) => int);
/* tuple */
type foo = option((int => int, int => int));
type foo = option((int => int, string));
type foo =
option((string, int => int, string));
type foo = option((string, int => int));
/* other preceeding/trailing */
type foo = option(int => int, int => int);
type foo = option(int => int, string);
type foo = option(string, int => int, string);
type foo = option(string, int => int);
/* preceeding/trailing, more args */
type foo =
option(
(int, string) => int,
(int, string) => int,
);
type foo = option((int, string) => int, string);
type foo =
option(string, (int, string) => int, string);
type foo = option(string, (int, string) => int);
/* others */
type foo =
option(string, option(int => int), string);
type foo =
option(
string,
option(option(option(int) => int)),
string,
);
type foo =
option(
string,
option([@foo] option(option(int) => int)),
string,
);
/* with attributes */
type foo =
option([@foo] [@bar] (int => [@baz] int));
type foo =
option([@foo] (([@bar] int) => [@baz] int));
type foo = option(int => [@foo] (int => int));
type foo = option([@foo] ((int => int) => int));
type foo = option([@foo] ((int, int) => int));
/* tuple */
type foo =
option(
[@foo] (
[@bar] (int => int),
[@baz] (int => int),
),
);
type foo =
option(
[@foo] ([@bar] (int => int), [@baz] string),
);
type foo =
option(
[@foo] (
[@bar] string,
[@baz] (int => int),
[@qux] string,
),
);
type foo =
option((string, [@foo] (int => int)));
/* other preceeding/trailing */
type foo =
option(
[@foo] (int => int),
[@bar] (int => int),
);
type foo =
option([@foo] (int => int), [@bar] string);
type foo =
option(
[@foo] string,
[@bar] (int => int),
[@baz] string,
);
type foo =
option([@foo] string, [@bar] (int => int));
/* preceeding/trailing, more args */
type foo =
option(
[@foo] ((int, string) => int),
[@bar] ((int, string) => int),
);
type foo =
option(
[@foo] ((int, string) => int),
[@bar] string,
);
type foo =
option(
[@foo] string,
[@bar] ((int, string) => int),
[@baz] string,
);
type foo =
option(
[@foo] string,
[@bar] ((int, string) => int),
);
/* === end test wrapping for arrows === */
/* https://github.com/facebook/reason/issues/2073 */
type a =
array({
.
"someStringKeyThatCausesLineToBreak": string,
});
/* Inline type record non punned field */
type b = {punned: [@with_attribute] punned};
/* Breakline record non punned field */
type c = {
a: string,
b: string,
punned: [@with_attribute] punned,
};
type%x foo = int;
type%x foo +=
| Int;
================================================
FILE: test/typeParameters.t/input.re
================================================
/**
* Testing type parameters.
*/
type threeThings<'t> = ('t, 't, 't);
type listOf<'t> = list<'t>;
type underscoreParam<_> = Underscored;
type underscoreParamCovariance<+_> = Underscored;
type underscoreParamContravariance<-_> = Underscored;
type tickParamCovariance<+'a> = Underscored;
type tickParamContravariance<-'a> = Underscored;
let x : option<list<'a> > = None;
type myFunctionType<'a> = (list<('a, 'a)>, int => option<list<'a> >);
let funcAnnoted = (~a: list<int>=[0, 1, ], ()) => a;
/**
* Syntax that would be likely to conflict with lexing parsing of < > syntax.
*/
let zero = 0;
let isGreaterThanNegFive = zero > - 5;
let isGreaterThanNegFive2 = zero > -5;
let isGreaterThanNegFive3 = zero >(-5);
let isGreaterThanEqNegFive = zero >= -5;
let isGreaterThanEqNegFive2 = zero >= -5;
let isGreaterThanEqNegFive3 = zero >=(-5);
let (>>=) = (a, b) => a >= b;
let isSuperGreaterThanEqNegFive = zero >>= - 5;
let isSuperGreaterThanEqNegFive2 = zero >>= -5;
let isSuperGreaterThanEqNegFive3 = zero >>= (-5);
let jsx= (~children, ()) => 0;
type t<'a> = 'a;
let optionArg = (~arg:option<t<int>>=?, ()) => arg;
let optionArgList = (~arg:option<list<list<int>>>=?, ()) => arg;
let defaultJsxArg = (~arg:t(int)=<jsx/>, ()) => arg;
let defaultFalse = (~arg:t<bool>=!true, ()) => arg;
/* Doesn't work on master either let defaultTrue = (~arg:t<bool>= !!true) => arg; */
/**
* Things likely to conflict or impact precedence.
*/
let neg=-1;
let tru=!false;
let x =
"arbitrary" === "example"
&& "how long" >= "can you get"
&& "seriously" <= "what is the line length";
let z = 0;
module Conss = {
let (>-) = (a, b) => a + b;
let four = 3 >- 1;
let two = 3 >- -1;
let four' = 3 >- - - 1;
let tr = 3 > - 1;
let tr' = 3 > - -1;
let tr'' = 3 > - - - 1;
}
module Idents = {
let (>-) = (a, b) => a + b;
let four = z >- z;
let two = z >- -z;
let four' = z >- - - z;
let tr = z > - z;
let tr' = z > - -z;
let tr'' = z > - - - z;
}
================================================
FILE: test/typeParameters.t/run.t
================================================
Format basic
$ refmt --print re ./input.re > ./formatted.re
Print the formatted file
$ cat ./formatted.re
/**
* Testing type parameters.
*/
type threeThings('t) = ('t, 't, 't);
type listOf('t) = list('t);
type underscoreParam(_) =
| Underscored;
type underscoreParamCovariance(+_) =
| Underscored;
type underscoreParamContravariance(-_) =
| Underscored;
type tickParamCovariance(+'a) =
| Underscored;
type tickParamContravariance(-'a) =
| Underscored;
let x: option(list('a)) = None;
type myFunctionType('a) = (
list(('a, 'a)),
int => option(list('a)),
);
let funcAnnoted = (~a: list(int)=[0, 1], ()) => a;
/**
* Syntax that would be likely to conflict with lexing parsing of < > syntax.
*/
let zero = 0;
let isGreaterThanNegFive = zero > (-5);
let isGreaterThanNegFive2 = zero > (-5);
let isGreaterThanNegFive3 = zero > (-5);
let isGreaterThanEqNegFive = zero >= (-5);
let isGreaterThanEqNegFive2 = zero >= (-5);
let isGreaterThanEqNegFive3 = zero >= (-5);
let (>>=) = (a, b) => a >= b;
let isSuperGreaterThanEqNegFive = zero >>= (-5);
let isSuperGreaterThanEqNegFive2 = zero >>= (-5);
let isSuperGreaterThanEqNegFive3 = zero >>= (-5);
let jsx = (~children, ()) => 0;
type t('a) = 'a;
let optionArg = (~arg: option(t(int))=?, ()) => arg;
let optionArgList =
(~arg: option(list(list(int)))=?, ()) => arg;
let defaultJsxArg = (~arg: t(int)=<jsx />, ()) => arg;
let defaultFalse = (~arg: t(bool)=!true, ()) => arg;
/* Doesn't work on master either let defaultTrue = (~arg:t<bool>= !!true) => arg; */
/**
* Things likely to conflict or impact precedence.
*/
let neg = (-1);
let tru = !false;
let x =
"arbitrary" === "example"
&& "how long" >= "can you get"
&& "seriously" <= "what is the line length";
let z = 0;
module Conss = {
let (>-) = (a, b) => a + b;
let four = 3 >- 1;
let two = 3 >- (-1);
let four' = 3 >- 1;
let tr = 3 > (-1);
let tr' = 3 > 1;
let tr'' = 3 > (-1);
};
module Idents = {
let (>-) = (a, b) => a + b;
let four = z >- z;
let two = z >- - z;
let four' = z >- - (- z);
let tr = z > - z;
let tr' = z > - (- z);
let tr'' = z > - (- (- z));
};
Type-check basics
$ ocamlc -c -pp 'refmt --print binary' -intf-suffix .rei -impl formatted.re
Format the formatted file back
$ refmt --print re ./formatted.re > ./formatted_back.re
Ensure idempotency: first format and second format are the same
$ diff formatted.re formatted_back.re
================================================
FILE: test/uchar-esc.t/input.re
================================================
let x = "\u{1F42B}";
let y = "\u{0}";
let y = "\u{00}";
let y = "\u{000}";
let y = "\u{000000}";
let y = "\u{0000E9}";
let y = "\u{10FFFF}";
let x = "\u{1F42B}\u{1F42B}\u{1F42B}\u{1F42B}\u{1F42B}\u{1F42B}";
let () = Format.eprintf ("x: %s@.", x);
// in a comment
/* "\u{1F42B}\u{1F42B}\u{1F42B}\u{1F42B}\u{1F42B}\u{1F42B}" */
================================================
FILE: test/uchar-esc.t/run.t
================================================
Test uchar escape lexing
$ refmt ./input.re
let x = "\u{1F42B}";
let y = "\u{0}";
let y = "\u{00}";
let y = "\u{000}";
let y = "\u{000000}";
let y = "\u{0000E9}";
let y = "\u{10FFFF}";
let x = "\u{1F42B}\u{1F42B}\u{1F42B}\u{1F42B}\u{1F42B}\u{1F42B}";
let () = Format.eprintf("x: %s@.", x);
// in a comment
/* "\u{1F42B}\u{1F42B}\u{1F42B}\u{1F42B}\u{1F42B}\u{1F42B}" */
check internal translation
$ ocamlc -dsource -pp 'refmt --print binary' -intf-suffix .rei -impl input.re -o test
let x = "\240\159\144\171"
let y = "\000"
let y = "\000"
let y = "\000"
let y = "\000"
let y = "\195\169"
let y = "\244\143\191\191"
let x =
"\240\159\144\171\240\159\144\171\240\159\144\171\240\159\144\171\240\159\144\171\240\159\144\171"
let () = Format.eprintf "x: %s@." x
$ ./test
x: 🐫🐫🐫🐫🐫🐫
================================================
FILE: test/uncurried.t/input.re
================================================
f(.);
[@attr] f(.);
[@bs] f();
f(. a, b, c);
[@attr] f(. a, b, c);
f(. a);
f(. (1, 2));
f([@bs] (1, 2));
f(. [@bs] (1, 2));
f(. (1, 2), (3, 4));
f(. [@bs] (1, 2), [@bs] (3, 4));
f(. [@bs] (1, 2), . [@bs] (3, 4));
f(. "string");
f(. "string", "2string");
f(. "string", . "2string");
f(. [@bs] "string", . [@bs] "2string");
f(. 1);
f(. [@bs] 1);
f(. {a: "supersupersupersupersupersuperlong", b: "supersupersupersupersupersuperlong"});
let f = (. a, b) => a + b;
let f = [@attr] (. a, b) => a + b;
let f = [@bs] (. a, b) => a + b;
let f = ("hello", (. b, c) => b + c);
let f = ("hello", [@attr] (. b, c) => b + c);
let f = ("hello", [@bs] (. b, c) => b + c);
let obj: tesla = {
pub drive = (. speed, safe) => (speed, safe);
pub drive2 = [@attr] (. speed, safe) => (speed, safe);
pub park = (.) => ();
pub park2 = [@attr] (.) => ();
};
type f = (. int, int) => int;
type f = [@attr] (. int, int) => int;
type f = [@bs] ((int, int) => int);
type z = [@bs] unit => unit;
type z = [@attr] [@bs] unit => unit;
type z = (. unit) => unit;
type tesla = {.
drive: (. int, int) => int
};
class type _rect =
[@bs]
{
[@bs.set] pub height: int;
[@bs.set] pub width: int;
pub draw: unit => unit
};
class type _rect = {.
[@bs.set]
pub height: int;
[@bs.set]
pub width: int;
pub draw: unit => unit
};
funWithCb("text", (.) => doStuff());
funWithCb("text", (. test) => doStuff());
funWithCb("text", [@attr] (. arg) => doStuff());
test(~desc="my test", (.) => {
let x = a + b;
let y = z + c;
x + y;
});
test(~desc="my test", [@attr] (. a, b, c) => {
let x = a + b;
let y = z + c;
x + y;
});
Thing.map(
~a=?foo,
~b=?bar,
~c=?baz,
~d=?foo2,
~e=?bakjlksjdf,
~f=?okokokok,
~cb=[@attr] (. abc, z) => {
let x = 1;
MyModuleBlah.toList(x, argument);
}
);
type f = int => (. int) => unit;
type f = (int, . int) => unit;
add(. 2);
add(. 2, . 3);
([@bs] add(2, [@bs] 3));
add(. 2, 3, 4, . 5, 6, 7, . 8, 9, 10);
type timerId;
[@bs.val] external setTimeout : ([@bs] (unit => unit), int) => timerId = "setTimeout";
let id = setTimeout([@bs] (() => Js.log("hello")), 1000);
let id = setTimeout(1000, [@bs] (() => Js.log("hello")));
foo([@bs] {val a = 1});
[@bs] foo([@bs] {val a = 1});
foo(. [@bs] {val a = 1});
foo([@attr1][@bs][@attr2] {val a = 1});
add([@attr][@bs][@attr] 1);
[@bs] add([@attr][@bs][@attr] 1);
add(. [@attr][@bs][@attr] 1);
let a = [@bs] foo ([@bs] foo(3));
let a = foo(. foo(. 3));
add(1, 2, . 3, 4);
add(1, . 2, 3, 4);
add(1, 2, 3, . 4);
let run = (~dry as [@attr] dry: bool=false, ~mMap as mMap: string=?, logger) => {
};
f(. _ => 1);
f(.a, _ => 1);
f(.a, (._) => 1);
let u = (. ~f : t , a , b) => {
f(.~x=a,~y=b) -> Js.log;
f(.~y=b,~x=a) -> Js.log;
};
================================================
FILE: test/uncurried.t/run.t
================================================
Format uncurried
$ refmt ./input.re
f(.);
[@attr]
f(.);
f(.);
f(. a, b, c);
[@attr]
f(. a, b, c);
f(. a);
f(. (1, 2));
f([@bs] (1, 2));
f(. [@bs] (1, 2));
f(. (1, 2), (3, 4));
f(. [@bs] (1, 2), [@bs] (3, 4));
(f(. [@bs] (1, 2)))(. [@bs] (3, 4));
f(. "string");
f(. "string", "2string");
(f(. "string"))(. "2string");
(f(. [@bs] "string"))(. [@bs] "2string");
f(. 1);
f(. [@bs] 1);
f(. {
a: "supersupersupersupersupersuperlong",
b: "supersupersupersupersupersuperlong",
});
let f = (. a, b) => a + b;
let f = [@attr] ((. a, b) => a + b);
let f = (. a, b) => a + b;
let f = ("hello", (. b, c) => b + c);
let f = ("hello", [@attr] ((. b, c) => b + c));
let f = ("hello", (. b, c) => b + c);
let obj: tesla = {
pub drive = (. speed, safe) => (speed, safe);
pub drive2 =
[@attr] ((. speed, safe) => (speed, safe));
pub park = (.) => ();
pub park2 = [@attr] ((.) => ())
};
type f = (. int, int) => int;
type f = [@attr] ((. int, int) => int);
type f = (. int, int) => int;
type z = (. unit) => unit;
type z = [@attr] ((. unit) => unit);
type z = (. unit) => unit;
type tesla = {. drive: (. int, int) => int };
class type _rect =
[@bs]
{
[@bs.set]
pub height: int;
[@bs.set]
pub width: int;
pub draw: unit => unit;
};
class type _rect =
[@u]
{
[@bs.set]
pub height: int;
[@bs.set]
pub width: int;
pub draw: unit => unit;
};
funWithCb("text", (.) => doStuff());
funWithCb("text", (. test) => doStuff());
funWithCb("text", [@attr] (. arg) => doStuff());
test(~desc="my test", (.) => {
let x = a + b;
let y = z + c;
x + y;
});
test(~desc="my test", [@attr] (. a, b, c) => {
let x = a + b;
let y = z + c;
x + y;
});
Thing.map(
~a=?foo,
~b=?bar,
~c=?baz,
~d=?foo2,
~e=?bakjlksjdf,
~f=?okokokok,
~cb=[@attr] (. abc, z) => {
let x = 1;
MyModuleBlah.toList(x, argument);
},
);
type f = int => (. int) => unit;
type f = int => (. int) => unit;
add(. 2);
(add(. 2))(. 3);
add(. 2, [@bs] 3);
((add(. 2, 3, 4))(. 5, 6, 7))(. 8, 9, 10);
type timerId;
[@bs.val]
external setTimeout:
((. unit) => unit, int) => timerId =
"setTimeout";
let id =
setTimeout((.) => Js.log("hello"), 1000);
let id =
setTimeout(1000, (.) => Js.log("hello"));
foo([@bs] { val a = 1 });
foo(. [@bs] { val a = 1 });
foo(. [@bs] { val a = 1 });
foo([@attr1] [@bs] [@attr2] { val a = 1 });
add([@attr] [@bs] [@attr] 1);
add(. [@attr] [@bs] [@attr] 1);
add(. [@attr] [@bs] [@attr] 1);
let a = foo(. foo(. 3));
let a = foo(. foo(. 3));
(add(1, 2))(. 3, 4);
(add(1))(. 2, 3, 4);
(add(1, 2, 3))(. 4);
let run =
(
~dry as [@attr] dry: bool=false,
~mMap: string=?,
logger,
) => {};
f(. _ => 1);
f(. a, _ => 1);
f(. a, (. _) => 1);
let u =
(. ~f: t, a, b) => {
f(. ~x=a, ~y=b)->Js.log;
f(. ~y=b, ~x=a)->Js.log;
};
================================================
FILE: test/unicodeIdentifiers.t/input.re
================================================
type saison = Hiver | Été | Printemps | Automne;
let x = Été;
let x = {été|xxx|été};
let x = {%été|xxx|};
let là = (ça) => ça;
let _ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖØÙÚÛÜÝÞßàáâãäåæçèéêëìíîïðñòóôõöøùúûüýþÿŠšŽžŒœŸ
= "ok";
type t = Æsop | Âcre | Ça | Élégant | Öst | Œuvre;
let été = "summer";
let ça = "that";
let straße = "street";
let øre = "ear";
/* NFD representation */
let f = fun
| Æsop => 1 | Âcre => 2 | Ça => 3 | Élégant => 4 | Öst => 5 | Œuvre => 6;
let l = [été, ça, straße, øre];
let s = _ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖØÙÚÛÜÝÞßàáâãäåæçèéêëìíîïðñòóôõöøùúûüýþÿŠšŽžŒœŸ;
let () = assert (f(Élégant) /* NFC encoded */ == 4);
let () = {
let called = ref(false);
let élégant /* NFC encoded */ () = called := true;
élégant /* NFD encoded */ (); assert (!called);
};
/* The following two defs should error with 'Multiple definition…' */
module Élégant /* NFC encoded */ = {};
module Élégant /* NFD encoded */ = {};
/** Quoted strings and extensions */
let x = {où|x|où};
let ko = {%Là |x|};
let x = {%âcre.name été|x|été};
let x = {%Âcre.sub été|x|été};
let x = {%âcre.m|x|};
let%À.ça x = ();
let x = /* {été|*)|été}*/ ();
let y = /* This is not a valid quoted string delimiter: {Été|*/ ();
================================================
FILE: test/unicodeIdentifiers.t/run.t
================================================
Format file with unicode identifiers
$ refmt ./input.re | tee output.re
type saison =
| Hiver
| Été
| Printemps
| Automne;
let x = Été;
let x = {été|xxx|été};
let x = {%été |xxx|};
let là = ça => ça;
let _ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖØÙÚÛÜÝÞßàáâãäåæçèéêëìíîïðñòóôõöøùúûüýþÿŠšŽžŒœŸ = "ok";
type t =
| Æsop
| Âcre
| Ça
| Élégant
| Öst
| Œuvre;
let été = "summer";
let ça = "that";
let straße = "street";
let øre = "ear";
/* NFD representation */
let f =
fun
| Æsop => 1
| Âcre => 2
| Ça => 3
| Élégant => 4
| Öst => 5
| Œuvre => 6;
let l = [été, ça, straße, øre];
let s = _ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖØÙÚÛÜÝÞßàáâãäåæçèéêëìíîïðñòóôõöøùúûüýþÿŠšŽžŒœŸ;
let () =
assert(f(Élégant) /* NFC encoded */ == 4);
let () = {
let called = ref(false);
let élégant = /* NFC encoded */ () =>
called := true;
élégant /* NFD encoded */();
assert(!called);
};
/* The following two defs should error with 'Multiple definition…' */
module Élégant /* NFC encoded */ = {};
module Élégant /* NFD encoded */ = {};
/** Quoted strings and extensions */
let x = {où|x|où};
let ko = {%Là |x|};
let x = {%âcre.name été|x|été};
let x = {%Âcre.sub été|x|été};
let x = {%âcre.m |x|};
let%À.ça x = ();
let x = /* {été|*)|été}*/ ();
let y =
/* This is not a valid quoted string delimiter: {Été|*/
();
Test idempotency
$ refmt output.re
type saison =
| Hiver
| Été
| Printemps
| Automne;
let x = Été;
let x = {été|xxx|été};
let x = {%été |xxx|};
let là = ça => ça;
let _ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖØÙÚÛÜÝÞßàáâãäåæçèéêëìíîïðñòóôõöøùúûüýþÿŠšŽžŒœŸ = "ok";
type t =
| Æsop
| Âcre
| Ça
| Élégant
| Öst
| Œuvre;
let été = "summer";
let ça = "that";
let straße = "street";
let øre = "ear";
/* NFD representation */
let f =
fun
| Æsop => 1
| Âcre => 2
| Ça => 3
| Élégant => 4
| Öst => 5
| Œuvre => 6;
let l = [été, ça, straße, øre];
let s = _ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖØÙÚÛÜÝÞßàáâãäåæçèéêëìíîïðñòóôõöøùúûüýþÿŠšŽžŒœŸ;
let () =
assert(f(Élégant) /* NFC encoded */ == 4);
let () = {
let called = ref(false);
let élégant = /* NFC encoded */ () =>
called := true;
élégant /* NFD encoded */();
assert(!called);
};
/* The following two defs should error with 'Multiple definition…' */
module Élégant /* NFC encoded */ = {};
module Élégant /* NFD encoded */ = {};
/** Quoted strings and extensions */
let x = {où|x|où};
let ko = {%Là |x|};
let x = {%âcre.name été|x|été};
let x = {%Âcre.sub été|x|été};
let x = {%âcre.m |x|};
let%À.ça x = ();
let x = /* {été|*)|été}*/ ();
let y =
/* This is not a valid quoted string delimiter: {Été|*/
();
================================================
FILE: test/value-constraint-alias-pattern.t/input.re
================================================
let x: t = x;
let (x as y): t = x;
let ((x, y) as pair): t = x;
let (Some(x) as opt): t = opt;
let ({url, mode} as target): t = x;
let ({url, mode, protocol} as target): TargetT.Safe.t =
multiTarget->MultiTargetT.toIgnorableTargetT;
let ({url, mode}): t = x;
let ({url: u, mode: m} as target): t = x;
let Foo.{url, mode}: t = x;
let (Foo.{url, mode} as target): t = x;
let ([x, y] as listPair): t = value;
let (_ as anyValue): t = value;
let ((x as y: u): t) = value;
================================================
FILE: test/value-constraint-alias-pattern.t/run.t
================================================
$ refmt ./input.re | tee formatted.re
let x: t = x;
let (x as y): t = x;
let ((x, y) as pair): t = x;
let (Some(x) as opt): t = opt;
let ({ url, mode } as target): t = x;
let ({ url, mode, protocol } as target): TargetT.Safe.t =
multiTarget->MultiTargetT.toIgnorableTargetT;
let { url, mode }: t = x;
let ({ url: u, mode: m } as target): t = x;
let Foo.{ url, mode } : t = x;
let (Foo.{ url, mode } as target): t = x;
let ([x, y] as listPair): t = value;
let (_ as anyValue): t = value;
let ((x as y: u): t) = value;
$ refmt ./formatted.re | tee formatted_back.re
let x: t = x;
let (x as y): t = x;
let ((x, y) as pair): t = x;
let (Some(x) as opt): t = opt;
let ({ url, mode } as target): t = x;
let ({ url, mode, protocol } as target): TargetT.Safe.t =
multiTarget->MultiTargetT.toIgnorableTargetT;
let { url, mode }: t = x;
let ({ url: u, mode: m } as target): t = x;
let Foo.{ url, mode } : t = x;
let (Foo.{ url, mode } as target): t = x;
let ([x, y] as listPair): t = value;
let (_ as anyValue): t = value;
let ((x as y: u): t) = value;
$ diff formatted.re formatted_back.re
================================================
FILE: test/variants.t/input.re
================================================
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
module LocalModule = {
type accessedThroughModule = | AccessedThroughModule;
type accessedThroughModuleWithArg =
| AccessedThroughModuleWith(int)| AccessedThroughModuleWithTwo(int,int);
};
type notTupleVariant = | NotActuallyATuple(int,int);
type attr = | A(int);
type attr += | Point(int, int);
type attr += | PointA{a : int, b : int};
type notTupleVariantExtraParens = | NotActuallyATuple2(int,int);
type simpleTupleVariant = | SimpleActuallyATuple((int, int));
type tupleVariant = | ActuallyATuple((int, int));
let intTuple = (20, 20);
let notTupled: notTupleVariant = NotActuallyATuple(10,10);
/* Doesn't work because we've correctly annotated parse tree nodes with explicit_arity! */
/* let notTupled: notTupleVariant = NotActuallyATuple (10, 10); */
let funcOnNotActuallyATuple (NotActuallyATuple(x,y)) = x + y;
/* let funcOnNotActuallyATuple (NotActuallyATuple (x, y)) = x + y; */
/* let notTupled: notTupleVariant = NotActuallyATuple intTuple; /*Doesn't work! */ */
/* At least the above acts as proof that there *is* a distinction that is
honored. */
let simpleTupled: simpleTupleVariant = SimpleActuallyATuple (10, 10);
let simpleTupled: simpleTupleVariant = SimpleActuallyATuple (intTuple);
/*Works! */
let NotActuallyATuple(x,y) = NotActuallyATuple (10, 20);
/* Doesn't work because we've correctly annotated parse tree nodes with explicit_arity! */
/* let unfortunatelyThisStillWorks: simpleTupleVariant = SimpleActuallyATuple 10 10; */
let yesTupled: tupleVariant = ActuallyATuple (10, 10);
let yesTupled: tupleVariant = ActuallyATuple (10, 10);
let yesTupled: tupleVariant = ActuallyATuple (intTuple);
type threeForms = | FormOne(int) | FormTwo(int) | FormThree;
let doesntCareWhichForm(x) = switch (x) {
| FormOne(q)
| FormTwo(q) => 10
| FormThree => 20
};
let doesntCareWhichFormAs(x) = switch (x) {
| FormOne(q) as ppp
| FormTwo(q) as ppp => 10
| FormThree => 20
};
type colorList1 = [
otherThingInheritedFrom
| `Red
| `Black
];
type colorList2 = [ | `Red | `Black | otherThingInheritedFrom ];
type colorList3 = [ bar | foo | `Red | `Black | foo ];
type colorList = [<
| `Red (int, int) &(int)
| `Black &(int, int) &(int)
| `Blue
> `Red `Black
];
1 + doesntCareWhichForm(FormOne(10));
1 + doesntCareWhichForm(FormTwo(10));
1 + doesntCareWhichForm(FormThree);
/* Destructured matching at function definition */
let accessDeeply(LocalModule.AccessedThroughModule) = 10;
let accessDeeplyWithArg
(LocalModule.AccessedThroughModuleWith(x) | LocalModule.AccessedThroughModuleWithTwo(_,x)) = x;
/* Destructured matching *not* at function definition */
let accessDeeply(x) = switch (x) {
| LocalModule.AccessedThroughModule => 10
| _ => 0
};
let accessDeeplyWithArg(x) = switch (x) {
| LocalModule.AccessedThroughModuleWith(x) => 10
| _ => 0
};
/* In OCaml's syntax, to capture the wrapped data, you do:
*
* let myFunc x = function | `Blah (p as retVal) -> retVal`
*
* In OCaml's syntax, to capture the entire pattern you do:
*
* let myFunc x = function | `Blah p as retVal -> retVal`
*/
let accessDeeply(x) = switch (x) {
| LocalModule.AccessedThroughModule as ppp => 1
};
let accessDeeplyWithArg(x) = switch (x) {
| LocalModule.AccessedThroughModuleWith (x as retVal) => retVal + 1
| LocalModule.AccessedThroughModuleWithTwo((x as retVal1),(y as retVal2)) => retVal1 + retVal2 + 1
};
/* Just to show that by default `as` captures much less aggresively */
let rec accessDeeplyWithArgRecursive(x,count) = switch (x) {
| LocalModule.AccessedThroughModuleWith(x) as entirePattern =>
/* It captures the whole pattern */
if (count > 0) {0;} else {accessDeeplyWithArgRecursive(entirePattern, count - 1);}
| LocalModule.AccessedThroughModuleWithTwo(x,y) as entirePattern =>
/* It captures the whole pattern */
if (count > 0) {0;} else {accessDeeplyWithArgRecursive(entirePattern, count - 1);}
};
accessDeeplyWithArgRecursive (LocalModule.AccessedThroughModuleWith(10), 10);
let run () {
TestUtils.printSection("Variants");
Printf.printf("%d %d \n",x,y);
};
type combination('a) = | HeresTwoConstructorArguments(int,int);
/** But then how do we parse matches in function arguments? */
/* We must require parenthesis around construction matching in function args only*/
let howWouldWeMatchFunctionArgs (HeresTwoConstructorArguments(x,y)) = x + y;
/* How would we annotate said arg? */
let howWouldWeMatchFunctionArgs (HeresTwoConstructorArguments(x,y): combination('wat)) = x + y;
let matchingTwoCurriedConstructorsInTuple(x) = switch (x) {
| (HeresTwoConstructorArguments(x,y), HeresTwoConstructorArguments(a,b)) => x + y + a + b
};
type twoCurriedConstructors = | TwoCombos (combination(int), combination(int));
let matchingTwoCurriedConstructorInConstructor(x) = switch (x) {
| TwoCombos (HeresTwoConstructorArguments(x,y), HeresTwoConstructorArguments(a,b)) => a + b + x + y
};
type twoCurriedConstructorsPolyMorphic('a) = | TwoCombos (combination('a), combination('a));
/* Matching records */
type pointRecord = {x: int, y: int};
type alsoHasARecord = | Blah | AlsoHasARecord(int,int,pointRecord);
let result = switch (AlsoHasARecord(10,10,{x: 10, y: 20})) {
| Blah => 1000
| AlsoHasARecord(a,b,{x, y}) => a + b + x + y
};
let rec commentPolymorphicCases: 'a . (option('a)) => int = fun | Some(a) => 1
/* Comment on one */
| None => 0;
let thisWontCompileButLetsSeeHowItFormats = switch (something) {
| Zero
| One => 10
};
let thisWontCompileButLetsSeeHowItFormats = fun | Zero
| One(_,_,_) => 10
| Two => 20;
/* Comment on two */
/**
* GADTs.
*/
type term(_) =
| Int(int) : term(int) | Add : term ((int, int) => int) | App (term (('b) => 'a), term ('b)) : term('a);
let rec eval: type a. (term(a)) => a =
fun | Int(n) => n
/* a = int */
| Add => (fun(x,y) => x + y)
/* a = int => int => int */
| App(f,x) => eval(f, eval(x));
let rec eval: type a. (term(a)) => a =
(x) => switch (x) {
| Int(n) => n
/* a = int */
| Add => (fun(x,y) => x + y)
/* a = int => int => int */
| App(f,x) => eval(f, eval(x))
};
/* eval called at types (b=>a) and b for fresh b */
let evalArg = App (App (Add, Int(1)), Int(1));
let two = eval (App (App(Add, Int(1)), Int(1)));
type someVariant = | Purple(int) | Yellow(int);
let Purple(x) | Yellow(x) = switch (Yellow(100), Purple(101)) {
| (Yellow(y), Purple(p)) => Yellow (p + y)
| (Purple(p), Yellow(y)) => Purple (y + p)
| (Purple(p), Purple(y)) => Yellow (y + p)
| (Yellow(p), Yellow(y)) => Purple (y + p)
};
type tuples = | Zero | One(int) | Two(int,int) | OneTuple (int, int);
let myTuple = OneTuple (20, 30);
let res = switch (myTuple) {
| Two(x,y) => try (Two(x,y)) {
| One => "hi"
| Two => "bye"
}
| One => switch (One) {
| One => "hi"
| _ => "bye"
}
};
/* FIXME type somePolyVariant = [ `Purple int | `Yellow int]; */
let ylw = `Yellow (100, 100);
let prp = `Purple (101, 100);
let res = switch (ylw, prp) {
| (`Yellow (y, y2), `Purple (p, p2)) => `Yellow (p + y, 0)
| (`Purple (p, p2), `Yellow (y, y2)) => `Purple (y + p, 0)
| (`Purple (p, p2), `Purple (y, y2)) => `Yellow (y + p, 0)
| (`Yellow (p, p2), `Yellow (y, y2)) => `Purple (y + p, 0)
};
let ylw = `Yellow(100);
let prp = `Purple(101);
let res = switch (ylw, prp) {
| (`Yellow y, `Purple p) => `Yellow (p + y)
| (`Purple p, `Yellow y) => `Purple (y + p)
| (`Purple p, `Purple y) => `Yellow (y + p)
| (`Yellow p, `Yellow y) => `Purple (y + p)
};
/*
* Now try polymorphic variants with *actual* tuples.
* You'll notice that these become indistinguishable from multiple constructor
* args! explicit_arity doesn't work on polymorphic variants!
*
* Way to resolve this (should also work for non-polymorphic variants):
*
* If you see *one* simple expr list that is a tuple, generate:
* Pexp_tuple (Pexp_tuple ..))
*
* If you see *one* simple expr list that is *not* a tuple, generate:
* Pexp..
*
* If you see *multiple* simple exprs, generate:
* Pexp_tuple..
*
* Though, I'm not sure this will even work.
*/
let ylw = `Yellow (100, 100);
let prp = `Purple (101, 101);
let res = switch (ylw, prp) {
| (`Yellow (y, y2), `Purple (p, p2)) => `Yellow (p + y, 0)
| (`Purple (p, p2), `Yellow (y, y2)) => `Purple (y + p, 0)
| (`Purple (p, p2), `Purple (y, y2)) => `Yellow (y + p, 0)
| (`Yellow (p, p2), `Yellow (y, y2)) => `Purple (y + p, 0)
};
let rec atLeastOneFlushableChildAndNoWipNoPending(composition,atPriority) = switch (composition) {
| [] => false
| [hd, ...tl] =>
switch (hd) {
| OpaqueGraph {lifecycle: Reconciled (_, [])} =>
atLeastOneFlushableChildAndNoWipNoPending(tl,atPriority)
| OpaqueGraph {lifecycle: ReconciledFlushable (priority, _, _, _, _, _)}
| OpaqueGraph {lifecycle: NeverReconciledFlushable (priority, _, _, _, _)}
when priority == AtPriority =>
noWipNoPending(tl,atPriority)
| SuperLongNameThatWontBreakByItselfSoWhenWillHaveToBreak
when priority == AtPrasldkfjalsdfjasdlfalsdkf =>
noWipNoPending(tl,atPriority)
| _ => false
}
};
/*
* When pretty printed, this appears to be multi-argument constructors.
*/
let prp = `Purple (101, 101);
let res = switch (prp) {
| `Yellow (y, y2) => `Yellow (y2 + y, 0)
| `Purple (p, p2) => `Purple (p2 + p, 0)
};
/*
* Testing explicit arity.
*/
let rec map(f) =
fun | Node(None,m) => Node(None, M.map(map(f),m))
| Node(LongModule.Path.None,m) => Node(None, M.map(map(f),m))
| Node(LongModule.Path.Some(v),m) => Node(Some(f(v)), M.map(map(f),m));
let myFunc(x,y,None) = "asdf";
let rec map(f) =
fun | Node(None,m) => Node(None, M.map(map(f),m))
| Node(LongModule.Path.None,m) => LongModule.Path.Node(LongModule.Path.None, M.map(map(f),m))
| Node(LongModule.Path.Some(v),m) =>
LongModule.Path.Node(LongModule.Path.Some(f(v)), M.map(map(f),m));
let myFunc(x,y,LongModule.Path.None) = "asdf";
let listPatternMembersNeedntBeSimple(x) = switch (x) {
| [] => ()
| [Blah(x,y), Foo(a,b), ...rest] => ()
| [Blah(x,y), Bar(a,b), ...rest] => ()
| _ => ()
};
let listTailPatternNeedntBeSimple(x) = switch (x) {
| [] => ()
/* Although this would never typecheck! */
| [Blah(x,y), Foo(a,b), ...Something(x)] => ()
| _ => ()
};
let listPatternMayEvenIncludeAliases(x) = switch (x) {
| [] => ()
/* Although this would never typecheck! */
| [Blah(x,y) as head, Foo(a,b) as head2, ...Something(x) as tail] => ()
| _ => ()
};
/*
* Testing extensible variants
*/
type attr = ..;
/* `of` is optional */
type attr += Str(string);
type attr += | Point(int,int);
type attr +=
| Float(float)
| Char(char);
type tag('props) = ..;
type titleProps = { title: string };
type tag('props) +=
| Title: tag(titleProps)
| Count(int):tag(int);
module Graph = {
type node = ..;
};
type Graph.node +=
| Str = Graph.Str;
type water = ..;
type water += pri Ocean;
type water += pri MineralWater | SpringWater | TapWater | TableWater;
type Graph.node += pri Node = Expr.Node;
type Graph.node += pri | Node = Expr.Node | Atom = Expr.Atom;
/* without single unit arg sugar */
MyConstructorWithSingleUnitArg(());
/* with single unit arg sugar */
MyConstructorWithSingleUnitArg();
/* without single unit arg sugar */
`polyVariantWithSingleUnitArg(());
/* with single unit arg sugar */
`polyVariantWithSingleUnitArg();
/* #1510: keep ({ and }) together on the same line when breaking */
Delete({ uuid: json |> Util.member("uuid") |> Util.to_string });
Delete((someLongStuf, someOtherLongStuff, okokokok));
Delete([someLongStuf, someOtherLongStuff, okokokok]);
Delete([|someLongStuf, someOtherLongStuff, okokokok|]);
Delete([someLongStuf, someOtherLongStuff, okokokok, ...veryES6]);
Delete({pub x = methodOne; pub y = methodTwo; pub z = methodThisBreaks});
`Delete({ uuid: json |> Util.member("uuid") |> Util.to_string });
`Delete((someLongStuf, someOtherLongStuff, okokokok));
`Delete([someLongStuf, someOtherLongStuff, okokokok]);
`Delete([|someLongStuf, someOtherLongStuff, okokokok|]);
`Delete([someLongStuf, someOtherLongStuff, okokokok, ...veryES6]);
`Delete({pub x = methodOne; pub y = methodTwo; pub z = methodThisBreaks});
let x: t = `Poly;
/* Format doc attrs consistent: https://github.com/facebook/reason/issues/2187 */
type t =
| /** This is some documentation that might be fairly long and grant a line break */
A
| /** Shorter docs */
B
| /** Some more longer docs over here that make sense to break lines on too */
C;
/* https://github.com/facebook/reason/issues/1828 */
type widget_state = [
| `DEFAULT /* here */
| `HOVER
| `ACTIVE
];
/* [| purposely without space */
type apiKeyError = [|`Dev |`Prod];
/* other polyvar variations */
type apiKeyError = [ | `Dev |`Prod];
type apiKeyError = [ `Dev |`Prod];
/* Coercion without ground */
let x :> [> `A | `B ] = `A;
/* Coercion with ground */
let x : foo :> [> `A | `B ] = `A;
================================================
FILE: test/variants.t/run.t
================================================
Format variants
$ refmt ./input.re
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
module LocalModule = {
type accessedThroughModule =
| AccessedThroughModule;
type accessedThroughModuleWithArg =
| AccessedThroughModuleWith(int)
| AccessedThroughModuleWithTwo(int, int);
};
type notTupleVariant =
| NotActuallyATuple(int, int);
type attr =
| A(int);
type attr +=
| Point(int, int);
type attr +=
| PointA({
a: int,
b: int,
});
type notTupleVariantExtraParens =
| NotActuallyATuple2(int, int);
type simpleTupleVariant =
| SimpleActuallyATuple((int, int));
type tupleVariant =
| ActuallyATuple((int, int));
let intTuple = (20, 20);
let notTupled: notTupleVariant =
NotActuallyATuple(10, 10);
/* Doesn't work because we've correctly annotated parse tree nodes with explicit_arity! */
/* let notTupled: notTupleVariant = NotActuallyATuple (10, 10); */
let funcOnNotActuallyATuple =
(NotActuallyATuple(x, y)) =>
x + y;
/* let funcOnNotActuallyATuple (NotActuallyATuple (x, y)) = x + y; */
/* let notTupled: notTupleVariant = NotActuallyATuple intTuple; /*Doesn't work! */ */
/* At least the above acts as proof that there *is* a distinction that is
honored. */
let simpleTupled: simpleTupleVariant =
SimpleActuallyATuple(10, 10);
let simpleTupled: simpleTupleVariant =
SimpleActuallyATuple(intTuple);
/*Works! */
let NotActuallyATuple(x, y) =
NotActuallyATuple(10, 20);
/* Doesn't work because we've correctly annotated parse tree nodes with explicit_arity! */
/* let unfortunatelyThisStillWorks: simpleTupleVariant = SimpleActuallyATuple 10 10; */
let yesTupled: tupleVariant =
ActuallyATuple(10, 10);
let yesTupled: tupleVariant =
ActuallyATuple(10, 10);
let yesTupled: tupleVariant =
ActuallyATuple(intTuple);
type threeForms =
| FormOne(int)
| FormTwo(int)
| FormThree;
let doesntCareWhichForm = x =>
switch (x) {
| FormOne(q)
| FormTwo(q) => 10
| FormThree => 20
};
let doesntCareWhichFormAs = x =>
switch (x) {
| FormOne(q) as ppp
| FormTwo(q) as ppp => 10
| FormThree => 20
};
type colorList1 = [
otherThingInheritedFrom
| `Red
| `Black
];
type colorList2 = [
| `Red
| `Black
| otherThingInheritedFrom
];
type colorList3 = [
bar
| foo
| `Red
| `Black
| foo
];
type colorList = [<
| `Red(int, int) &(int)
| `Black&(int, int) &(int)
| `Blue
> `Red `Black
];
1 + doesntCareWhichForm(FormOne(10));
1 + doesntCareWhichForm(FormTwo(10));
1 + doesntCareWhichForm(FormThree);
/* Destructured matching at function definition */
let accessDeeply =
(LocalModule.AccessedThroughModule) => 10;
let accessDeeplyWithArg =
(
LocalModule.AccessedThroughModuleWith(x) |
LocalModule.AccessedThroughModuleWithTwo(
_,
x,
),
) => x;
/* Destructured matching *not* at function definition */
let accessDeeply = x =>
switch (x) {
| LocalModule.AccessedThroughModule => 10
| _ => 0
};
let accessDeeplyWithArg = x =>
switch (x) {
| LocalModule.AccessedThroughModuleWith(x) => 10
| _ => 0
};
/* In OCaml's syntax, to capture the wrapped data, you do:
*
* let myFunc x = function | `Blah (p as retVal) -> retVal`
*
* In OCaml's syntax, to capture the entire pattern you do:
*
* let myFunc x = function | `Blah p as retVal -> retVal`
*/
let accessDeeply = x =>
switch (x) {
| LocalModule.AccessedThroughModule as ppp => 1
};
let accessDeeplyWithArg = x =>
switch (x) {
| LocalModule.AccessedThroughModuleWith(
x as retVal,
) =>
retVal + 1
| LocalModule.AccessedThroughModuleWithTwo(
x as retVal1,
y as retVal2,
) =>
retVal1 + retVal2 + 1
};
/* Just to show that by default `as` captures much less aggresively */
let rec accessDeeplyWithArgRecursive =
(x, count) =>
switch (x) {
| LocalModule.AccessedThroughModuleWith(x) as entirePattern =>
/* It captures the whole pattern */
if (count > 0) {
0;
} else {
accessDeeplyWithArgRecursive(
entirePattern,
count - 1,
);
}
| LocalModule.AccessedThroughModuleWithTwo(
x,
y,
) as entirePattern =>
/* It captures the whole pattern */
if (count > 0) {
0;
} else {
accessDeeplyWithArgRecursive(
entirePattern,
count - 1,
);
}
};
accessDeeplyWithArgRecursive(
LocalModule.AccessedThroughModuleWith(10),
10,
);
let run = () => {
TestUtils.printSection("Variants");
Printf.printf("%d %d \n", x, y);
};
type combination('a) =
| HeresTwoConstructorArguments(int, int);
/** But then how do we parse matches in function arguments? */
/* We must require parenthesis around construction matching in function args only*/
let howWouldWeMatchFunctionArgs =
(HeresTwoConstructorArguments(x, y)) =>
x + y;
/* How would we annotate said arg? */
let howWouldWeMatchFunctionArgs =
(
HeresTwoConstructorArguments(x, y):
combination('wat),
) =>
x + y;
let matchingTwoCurriedConstructorsInTuple = x =>
switch (x) {
| (
HeresTwoConstructorArguments(x, y),
HeresTwoConstructorArguments(a, b),
) =>
x + y + a + b
};
type twoCurriedConstructors =
| TwoCombos(
combination(int),
combination(int),
);
let matchingTwoCurriedConstructorInConstructor =
x =>
switch (x) {
| TwoCombos(
HeresTwoConstructorArguments(x, y),
HeresTwoConstructorArguments(a, b),
) =>
a + b + x + y
};
type twoCurriedConstructorsPolyMorphic('a) =
| TwoCombos(
combination('a),
combination('a),
);
/* Matching records */
type pointRecord = {
x: int,
y: int,
};
type alsoHasARecord =
| Blah
| AlsoHasARecord(int, int, pointRecord);
let result =
switch (
AlsoHasARecord(
10,
10,
{
x: 10,
y: 20,
},
)
) {
| Blah => 1000
| AlsoHasARecord(a, b, { x, y }) =>
a + b + x + y
};
let rec commentPolymorphicCases:
'a.
option('a) => int
=
fun
| Some(a) => 1
/* Comment on one */
| None => 0;
let thisWontCompileButLetsSeeHowItFormats =
switch (something) {
| Zero
| One => 10
};
let thisWontCompileButLetsSeeHowItFormats =
fun
| Zero
| One(_, _, _) => 10
| Two => 20;
/* Comment on two */
/**
* GADTs.
*/
type term(_) =
| Int(int): term(int)
| Add: term((int, int) => int)
| App(term('b => 'a), term('b)): term('a);
let rec eval: type a. term(a) => a =
fun
| Int(n) => n
/* a = int */
| Add => ((x, y) => x + y)
/* a = int => int => int */
| App(f, x) => eval(f, eval(x));
let rec eval: type a. term(a) => a = x =>
switch (x) {
| Int(n) => n
/* a = int */
| Add => ((x, y) => x + y)
/* a = int => int => int */
| App(f, x) => eval(f, eval(x))
};
/* eval called at types (b=>a) and b for fresh b */
let evalArg = App(App(Add, Int(1)), Int(1));
let two =
eval(App(App(Add, Int(1)), Int(1)));
type someVariant =
| Purple(int)
| Yellow(int);
let Purple(x) | Yellow(x) =
switch (Yellow(100), Purple(101)) {
| (Yellow(y), Purple(p)) => Yellow(p + y)
| (Purple(p), Yellow(y)) => Purple(y + p)
| (Purple(p), Purple(y)) => Yellow(y + p)
| (Yellow(p), Yellow(y)) => Purple(y + p)
};
type tuples =
| Zero
| One(int)
| Two(int, int)
| OneTuple(int, int);
let myTuple = OneTuple(20, 30);
let res =
switch (myTuple) {
| Two(x, y) =>
try(Two(x, y)) {
| One => "hi"
| Two => "bye"
}
| One =>
switch (One) {
| One => "hi"
| _ => "bye"
}
};
/* FIXME type somePolyVariant = [ `Purple int | `Yellow int]; */
let ylw = `Yellow((100, 100));
let prp = `Purple((101, 100));
let res =
switch (ylw, prp) {
| (`Yellow(y, y2), `Purple(p, p2)) =>
`Yellow((p + y, 0))
| (`Purple(p, p2), `Yellow(y, y2)) =>
`Purple((y + p, 0))
| (`Purple(p, p2), `Purple(y, y2)) =>
`Yellow((y + p, 0))
| (`Yellow(p, p2), `Yellow(y, y2)) =>
`Purple((y + p, 0))
};
let ylw = `Yellow(100);
let prp = `Purple(101);
let res =
switch (ylw, prp) {
| (`Yellow(y), `Purple(p)) => `Yellow(p + y)
| (`Purple(p), `Yellow(y)) => `Purple(y + p)
| (`Purple(p), `Purple(y)) => `Yellow(y + p)
| (`Yellow(p), `Yellow(y)) => `Purple(y + p)
};
/*
* Now try polymorphic variants with *actual* tuples.
* You'll notice that these become indistinguishable from multiple constructor
* args! explicit_arity doesn't work on polymorphic variants!
*
* Way to resolve this (should also work for non-polymorphic variants):
*
* If you see *one* simple expr list that is a tuple, generate:
* Pexp_tuple (Pexp_tuple ..))
*
* If you see *one* simple expr list that is *not* a tuple, generate:
* Pexp..
*
* If you see *multiple* simple exprs, generate:
* Pexp_tuple..
*
* Though, I'm not sure this will even work.
*/
let ylw = `Yellow((100, 100));
let prp = `Purple((101, 101));
let res =
switch (ylw, prp) {
| (`Yellow(y, y2), `Purple(p, p2)) =>
`Yellow((p + y, 0))
| (`Purple(p, p2), `Yellow(y, y2)) =>
`Purple((y + p, 0))
| (`Purple(p, p2), `Purple(y, y2)) =>
`Yellow((y + p, 0))
| (`Yellow(p, p2), `Yellow(y, y2)) =>
`Purple((y + p, 0))
};
let rec atLeastOneFlushableChildAndNoWipNoPending =
(composition, atPriority) =>
switch (composition) {
| [] => false
| [hd, ...tl] =>
switch (hd) {
| OpaqueGraph({
lifecycle: Reconciled(_, []),
}) =>
atLeastOneFlushableChildAndNoWipNoPending(
tl,
atPriority,
)
| OpaqueGraph({
lifecycle:
ReconciledFlushable(
priority,
_,
_,
_,
_,
_,
),
})
| OpaqueGraph({
lifecycle:
NeverReconciledFlushable(
priority,
_,
_,
_,
_,
),
})
when priority == AtPriority =>
noWipNoPending(tl, atPriority)
| SuperLongNameThatWontBreakByItselfSoWhenWillHaveToBreak
when
priority
== AtPrasldkfjalsdfjasdlfalsdkf =>
noWipNoPending(tl, atPriority)
| _ => false
}
};
/*
* When pretty printed, this appears to be multi-argument constructors.
*/
let prp = `Purple((101, 101));
let res =
switch (prp) {
| `Yellow(y, y2) => `Yellow((y2 + y, 0))
| `Purple(p, p2) => `Purple((p2 + p, 0))
};
/*
* Testing explicit arity.
*/
let rec map = f =>
fun
| Node(None, m) =>
Node(None, M.map(map(f), m))
| Node(LongModule.Path.None, m) =>
Node(None, M.map(map(f), m))
| Node(LongModule.Path.Some(v), m) =>
Node(Some(f(v)), M.map(map(f), m));
let myFunc = (x, y, None) => "asdf";
let rec map = f =>
fun
| Node(None, m) =>
Node(None, M.map(map(f), m))
| Node(LongModule.Path.None, m) =>
LongModule.Path.Node(
LongModule.Path.None,
M.map(map(f), m),
)
| Node(LongModule.Path.Some(v), m) =>
LongModule.Path.Node(
LongModule.Path.Some(f(v)),
M.map(map(f), m),
);
let myFunc = (x, y, LongModule.Path.None) => "asdf";
let listPatternMembersNeedntBeSimple = x =>
switch (x) {
| [] => ()
| [Blah(x, y), Foo(a, b), ...rest] => ()
| [Blah(x, y), Bar(a, b), ...rest] => ()
| _ => ()
};
let listTailPatternNeedntBeSimple = x =>
switch (x) {
| [] => ()
/* Although this would never typecheck! */
| [Blah(x, y), Foo(a, b), ...Something(x)] =>
()
| _ => ()
};
let listPatternMayEvenIncludeAliases = x =>
switch (x) {
| [] => ()
/* Although this would never typecheck! */
| [
Blah(x, y) as head,
Foo(a, b) as head2,
...Something(x) as tail,
] =>
()
| _ => ()
};
/*
* Testing extensible variants
*/
type attr = ..;
/* `of` is optional */
type attr +=
| Str(string);
type attr +=
| Point(int, int);
type attr +=
| Float(float)
| Char(char);
type tag('props) = ..;
type titleProps = {title: string};
type tag('props) +=
| Title: tag(titleProps)
| Count(int): tag(int);
module Graph = {
type node = ..;
};
type Graph.node +=
| Str = Graph.Str;
type water = ..;
type water +=
pri
| Ocean;
type water +=
pri
| MineralWater
| SpringWater
| TapWater
| TableWater;
type Graph.node +=
pri
| Node = Expr.Node;
type Graph.node +=
pri
| Node = Expr.Node
| Atom = Expr.Atom;
/* without single unit arg sugar */
MyConstructorWithSingleUnitArg();
/* with single unit arg sugar */
MyConstructorWithSingleUnitArg();
/* without single unit arg sugar */
`polyVariantWithSingleUnitArg();
/* with single unit arg sugar */
`polyVariantWithSingleUnitArg();
/* #1510: keep ({ and }) together on the same line when breaking */
Delete({
uuid:
json
|> Util.member("uuid")
|> Util.to_string,
});
Delete((
someLongStuf,
someOtherLongStuff,
okokokok,
));
Delete([
someLongStuf,
someOtherLongStuff,
okokokok,
]);
Delete([|
someLongStuf,
someOtherLongStuff,
okokokok,
|]);
Delete([
someLongStuf,
someOtherLongStuff,
okokokok,
...veryES6,
]);
Delete({
pub x = methodOne;
pub y = methodTwo;
pub z = methodThisBreaks
});
`Delete({
uuid:
json
|> Util.member("uuid")
|> Util.to_string,
});
`Delete((
someLongStuf,
someOtherLongStuff,
okokokok,
));
`Delete([
someLongStuf,
someOtherLongStuff,
okokokok,
]);
`Delete([|
someLongStuf,
someOtherLongStuff,
okokokok,
|]);
`Delete([
someLongStuf,
someOtherLongStuff,
okokokok,
...veryES6,
]);
`Delete({
pub x = methodOne;
pub y = methodTwo;
pub z = methodThisBreaks
});
let x: t = `Poly;
/* Format doc attrs consistent: https://github.com/facebook/reason/issues/2187 */
type t =
| /** This is some documentation that might be fairly long and grant a line break */
A
| /** Shorter docs */
B
| /** Some more longer docs over here that make sense to break lines on too */
C;
/* https://github.com/facebook/reason/issues/1828 */
type widget_state = [
| `DEFAULT /* here */
| `HOVER
| `ACTIVE
];
/* [| purposely without space */
type apiKeyError = [
| `Dev
| `Prod
];
/* other polyvar variations */
type apiKeyError = [
| `Dev
| `Prod
];
type apiKeyError = [
| `Dev
| `Prod
];
/* Coercion without ground */
let x :> [>
| `A
| `B
] = `A;
/* Coercion with ground */
let x: foo :> [>
| `A
| `B
] = `A;
/* Doesn't work because we've correctly annotated parse tree nodes with explicit_arity! */
/* let notTupled: notTupleVariant = NotActuallyATuple intTuple; /*Doesn't work! */ */
/* Doesn't work because we've correctly annotated parse tree nodes with explicit_arity! */
/* let unfortunatelyThisStillWorks: simpleTupleVariant = SimpleActuallyATuple 10 10; */
================================================
FILE: test/whitespace-re.t/input.re
================================================
module Test = {
open Belt;
open React;
type a = int;
type b = string;
let x = 12;
let y = 34;
};
/** recursive let bindings */
/* see below */
let foo = "abc"
and bar = "def"
and baz = "ghi";
/* with whitespace */
let foo = "abc"
and bar = "def"
and baz = "ghi";
/** with whitespace and attrs */
/* -> */
[@foo]
let foo = "abc"
[@bar]
and bar = "def"
[@baz]
and baz = "ghi";
module Comments = {
let z = 1;
/* comment *without* whitespace interleaved*/
let ab = 2;
let add = (a, b) => a + b;
/* comment *with* multiple newlines above */
let min = (a, b) => a - b;
let a = 1; /* trailing comment ok */
let b = 2;
/* comment on top */
let x = 1; /* this comment sits at the end of the line */
/* wow another one below too */
let add = Test.x;
/* this
is
a multiline
comment */
let minus = (a, b) => a - b;
/* look
another
multi
line
comment */
let vermenigvuldig = (a, b) => a * b;
/* attach another comment below
it spreads
over
multiple
line
*/
type x = {a: int /* comment1*/, b: string /* comment2 */};
};
module FloatingComments = {
let a = 1;
/* a */
/* b */
/* c */
let b = 1;
/* d */
let c = 1;
/* e */
/* f */
let d = 1;
/* g */
/* h */
/* i */
/* j */
/* k */
/* l */
let e = 1;
};
module FloatingMultiLineComments = {
let a = 1;
/* 1
2 */
/* ok
another one */
/* wow
here */
let b = 1;
/* float
-ing */
/* here
on the second */
let c = 1;
/* one
two */
/* three
four */
/* extreme
comment */
/* here
on two lines */
/* another
one */
/* chocolate
is
good */
let d = 2;
};
module type TestModuleType = {
type a = int;
type b = string;
let x: a;
let y: b;
};
let main = () => {
let%lwt tc = tcGetAddr(stdin);
let a = 1;
let%lwt () = tcsetattr(stdin, TCSANOW, tc);
let%lwt _i = write_string(stdout, s, 0, len);
();
};
module PatternMatching = {
let x = switch(color) {
| Black => ()
| Red => ()
| White => ()
};
/* with comments */
let color = switch (color) {
/* c1 */
/* c2 */
| Black =>
"black"
/* c3 */
/* c4 */
/* c5 */
/* c6 */
| Green => "green"
/* multi
line
comment */
| Blue => "blue"
};
};
/** recursive modules without whitespace */
module rec A: {type t; let a_fn: t => B.t; let of_float: float => t;} = {
type t = int;
let a_fn = x => B.of_int(x);
let of_float = x => int_of_float(x);
}
/* no whitespace */
and B: {type t; let another_fn: t => A.t; let of_int: int => t;} = {
type t = float;
let another_fn = x => A.of_float(x);
let of_int = x => float_of_int(x);
};
/** recursive modules with whitespace */
/* -> below */
module rec A: {type t; let a_fn: t => B.t; let of_float: float => t;} = {
type t = int;
let a_fn = x => B.of_int(x);
let of_float = x => int_of_float(x);
}
/** okok */
/* lala */
and B: {type t; let another_fn: t => A.t; let of_int: int => t;} = {
type t = float;
let another_fn = x => A.of_float(x);
let of_int = x => float_of_int(x);
};
/** recursive modules with attrs */
/* -> below */
[@foo1]
module rec A: {type t; let a_fn: t => B.t; let of_float: float => t;} = {
type t = int;
let a_fn = x => B.of_int(x);
let of_float = x => int_of_float(x);
}
/** okok */
/* lala */
[@foo2]
and B: {type t; let another_fn: t => A.t; let of_int: int => t;} = {
type t = float;
let another_fn = x => A.of_float(x);
let of_int = x => float_of_int(x);
};
module EdgeCase = {
let x = 1; /* a */
/* b */
/* c */
let x = 1;
};
/** Record-like expressions */
let r = {
a: 1,
b: 2,
c: 3,
};
/* with punning */
let r = {
a,
b,
c,
};
/* with spread */
let r = {
...x,
a: 1,
b: 2,
c: 3,
};
/* comments */
let r = {
...x,
/* a */
a: 1,
/* b */
/* c */
/* d */
b: 2,
/* e */
c: 3,
/* f */
d,
e,
};
/* string keys */
let x = {
"a": 1,
"b": 2,
"c": 3,
};
/* string keys punning */
let x = {
"a",
"b",
"c"
};
/* string keys with spread */
let x = {
...x,
"a": 1,
"b": 2,
"c": 3,
};
/* string keys with comments */
let x = {
...x,
/* a */
"a": 1,
/* b */
/* c */
/* d */
"b": 2,
/* e */
"c": 3,
/* f */
"d",
"e",
};
let make = _children => {
...component,
initialState: () => {
posts: [],
activeRoute: urlToRoute(ReasonReact.Router.dangerouslyGetInitialUrl()),
},
didMount: self => {
let watcherID =
ReasonReact.Router.watchUrl(url =>
self.send(ChangeRoute(urlToRoute(url)))
);
self.onUnmount(() => ReasonReact.Router.unwatchUrl(watcherID));
},
reducer: (action, state) =>
switch (action) {
| ChangeRoute(activeRoute) =>
ReasonReact.Update({...state, activeRoute})
| FetchCats => ReasonReact.NoUpdate
},
render: ({state: {posts, activeRoute}}) =>
<div>
<h1> <a href="/"> {ReasonReact.string("Instagram")} </a> </h1>
{
switch (activeRoute) {
| Default => <Grid posts />
| Detail(postId) => <Single posts postId />
}
}
</div>,
};
// Recursive types
// Also create another form for splicing in nodes into otherwise fixed length sets.
type elem('t) =
| Empty: elem(empty)
constraint 't = ('st, 'a) => 'subtree
and subtree('t) =
| EmptyInstance: subtree(empty);
// Also create another form for splicing in nodes into otherwise fixed length sets.
type elem('t) =
| Empty: elem(empty)
constraint 't = ('st, 'a) => 'subtree
and subtree('t) =
| EmptyInstance: subtree(empty);
type elem('t) =
| Empty: elem(empty)
constraint 't = ('st, 'a) => 'subtree
// trailing comment
// leading comment
and subtree('t) =
| EmptyInstance: subtree(empty);
type elem('t) =
| Empty: elem(empty)
constraint 't = ('st, 'a) => 'subtree
// trailing comment
// in between
// leading comment
and subtree('t) =
| EmptyInstance: subtree(empty);
// with attrs
type elem('t) =
| Empty: elem(empty)
constraint 't = ('st, 'a) => 'subtree
[@attr]
and subtree('t) =
| EmptyInstance: subtree(empty);
// with attrs
type elem('t) =
| Empty: elem(empty)
constraint 't = ('st, 'a) => 'subtree
[@attr]
and subtree('t) =
| EmptyInstance: subtree(empty);
let f = (a, b) => a + b;
/* this comment sticks at the end */
/* another one below the structure */
/* this one should stick */
/* :) */
================================================
FILE: test/whitespace-re.t/run.t
================================================
Format whitespace in .re files
$ refmt ./input.re
module Test = {
open Belt;
open React;
type a = int;
type b = string;
let x = 12;
let y = 34;
};
/** recursive let bindings */
/* see below */
let foo = "abc"
and bar = "def"
and baz = "ghi";
/* with whitespace */
let foo = "abc"
and bar = "def"
and baz = "ghi";
/** with whitespace and attrs */
/* -> */
[@foo]
let foo = "abc"
[@bar]
and bar = "def"
[@baz]
and baz = "ghi";
module Comments = {
let z = 1;
/* comment *without* whitespace interleaved*/
let ab = 2;
let add = (a, b) => a + b;
/* comment *with* multiple newlines above */
let min = (a, b) => a - b;
let a = 1; /* trailing comment ok */
let b = 2;
/* comment on top */
let x = 1; /* this comment sits at the end of the line */
/* wow another one below too */
let add = Test.x;
/* this
is
a multiline
comment */
let minus = (a, b) => a - b;
/* look
another
multi
line
comment */
let vermenigvuldig = (a, b) => a * b;
/* attach another comment below
it spreads
over
multiple
line
*/
type x = {
a: int /* comment1*/,
b: string /* comment2 */,
};
};
module FloatingComments = {
let a = 1;
/* a */
/* b */
/* c */
let b = 1;
/* d */
let c = 1;
/* e */
/* f */
let d = 1;
/* g */
/* h */
/* i */
/* j */
/* k */
/* l */
let e = 1;
};
module FloatingMultiLineComments = {
let a = 1;
/* 1
2 */
/* ok
another one */
/* wow
here */
let b = 1;
/* float
-ing */
/* here
on the second */
let c = 1;
/* one
two */
/* three
four */
/* extreme
comment */
/* here
on two lines */
/* another
one */
/* chocolate
is
good */
let d = 2;
};
module type TestModuleType = {
type a = int;
type b = string;
let x: a;
let y: b;
};
let main = () => {
let%lwt tc = tcGetAddr(stdin);
let a = 1;
let%lwt () = tcsetattr(stdin, TCSANOW, tc);
let%lwt _i = write_string(stdout, s, 0, len);
();
};
module PatternMatching = {
let x =
switch (color) {
| Black => ()
| Red => ()
| White => ()
};
/* with comments */
let color =
switch (color) {
/* c1 */
/* c2 */
| Black => "black"
/* c3 */
/* c4 */
/* c5 */
/* c6 */
| Green => "green"
/* multi
line
comment */
| Blue => "blue"
};
};
/** recursive modules without whitespace */
module rec A: {
type t;
let a_fn: t => B.t;
let of_float: float => t;
} = {
type t = int;
let a_fn = x => B.of_int(x);
let of_float = x => int_of_float(x);
}
/* no whitespace */
and B: {
type t;
let another_fn: t => A.t;
let of_int: int => t;
} = {
type t = float;
let another_fn = x => A.of_float(x);
let of_int = x => float_of_int(x);
};
/** recursive modules with whitespace */
/* -> below */
module rec A: {
type t;
let a_fn: t => B.t;
let of_float: float => t;
} = {
type t = int;
let a_fn = x => B.of_int(x);
let of_float = x => int_of_float(x);
}
/** okok */
/* lala */
and B: {
type t;
let another_fn: t => A.t;
let of_int: int => t;
} = {
type t = float;
let another_fn = x => A.of_float(x);
let of_int = x => float_of_int(x);
};
/** recursive modules with attrs */
/* -> below */
[@foo1]
module rec A: {
type t;
let a_fn: t => B.t;
let of_float: float => t;
} = {
type t = int;
let a_fn = x => B.of_int(x);
let of_float = x => int_of_float(x);
}
/** okok */
/* lala */
[@foo2]
and B: {
type t;
let another_fn: t => A.t;
let of_int: int => t;
} = {
type t = float;
let another_fn = x => A.of_float(x);
let of_int = x => float_of_int(x);
};
module EdgeCase = {
let x = 1; /* a */
/* b */
/* c */
let x = 1;
};
/** Record-like expressions */
let r = {
a: 1,
b: 2,
c: 3,
};
/* with punning */
let r = {
a,
b,
c,
};
/* with spread */
let r = {
...x,
a: 1,
b: 2,
c: 3,
};
/* comments */
let r = {
...x,
/* a */
a: 1,
/* b */
/* c */
/* d */
b: 2,
/* e */
c: 3,
/* f */
d,
e,
};
/* string keys */
let x = {
"a": 1,
"b": 2,
"c": 3,
};
/* string keys punning */
let x = {
"a": a,
"b": b,
"c": c,
};
/* string keys with spread */
let x = {
...x,
"a": 1,
"b": 2,
"c": 3,
};
/* string keys with comments */
let x = {
...x,
/* a */
"a": 1,
/* b */
/* c */
/* d */
"b": 2,
/* e */
"c": 3,
/* f */
"d": d,
"e": e,
};
let make = _children => {
...component,
initialState: () => {
posts: [],
activeRoute:
urlToRoute(
ReasonReact.Router.dangerouslyGetInitialUrl(),
),
},
didMount: self => {
let watcherID =
ReasonReact.Router.watchUrl(url =>
self.send(
ChangeRoute(urlToRoute(url)),
)
);
self.onUnmount(() =>
ReasonReact.Router.unwatchUrl(watcherID)
);
},
reducer: (action, state) =>
switch (action) {
| ChangeRoute(activeRoute) =>
ReasonReact.Update({
...state,
activeRoute,
})
| FetchCats => ReasonReact.NoUpdate
},
render:
({ state: { posts, activeRoute } }) =>
<div>
<h1>
<a href="/">
{ReasonReact.string("Instagram")}
</a>
</h1>
{switch (activeRoute) {
| Default => <Grid posts />
| Detail(postId) =>
<Single posts postId />
}}
</div>,
};
// Recursive types
// Also create another form for splicing in nodes into otherwise fixed length sets.
type elem('t) =
| Empty: elem(empty)
constraint 't = ('st, 'a) => 'subtree
and subtree('t) =
| EmptyInstance: subtree(empty);
// Also create another form for splicing in nodes into otherwise fixed length sets.
type elem('t) =
| Empty: elem(empty)
constraint 't = ('st, 'a) => 'subtree
and subtree('t) =
| EmptyInstance: subtree(empty);
type elem('t) =
| Empty: elem(empty)
constraint 't = ('st, 'a) => 'subtree
// trailing comment
// leading comment
and subtree('t) =
| EmptyInstance: subtree(empty);
type elem('t) =
| Empty: elem(empty)
constraint 't = ('st, 'a) => 'subtree
// trailing comment
// in between
// leading comment
and subtree('t) =
| EmptyInstance: subtree(empty);
// with attrs
type elem('t) =
| Empty: elem(empty)
constraint 't = ('st, 'a) => 'subtree
[@attr]
and subtree('t) =
| EmptyInstance: subtree(empty);
// with attrs
type elem('t) =
| Empty: elem(empty)
constraint 't = ('st, 'a) => 'subtree
[@attr]
and subtree('t) =
| EmptyInstance: subtree(empty);
let f = (a, b) => a + b;
/* this comment sticks at the end */
/* another one below the structure */
/* this one should stick */
/* :) */
================================================
FILE: test/whitespace-rei.t/input.rei
================================================
/** Interleave whitespace intelligently in signatures */
/* a */
let a: int;
/** Hi I'm a doc comment for some_definition */
let some_definition:
(
~what_a_long_label: M.its_a_type,
~just_need_to_make_this: long_enough_to_wrap
) =>
unit;
/** Hi I'm a doc comment for another_definition */
let another_definition: unit => unit;
/* b */
let b: int;
/* trailing */
/* kkk */
/* ---> */
/* amazing */
let f: int => int;
/** stick to x */
type x = string;
/** one newline below */
type x = string;
/** one newline below with comment */
/* comment */
type x = string;
/** doc comment attached */
type payload =
| PStr(structure)
| PSig(signature)
| PTyp(core_type)
| PPat(pattern, option(expression));
/** doc comment with whitespace */
type payload =
| PStr(structure)
| PSig(signature)
| PTyp(core_type)
| PPat(pattern, option(expression));
/** doc comment with whitespace and comment below */
/* comment here */
type payload =
| PStr(structure)
| PSig(signature)
| PTyp(core_type)
| PPat(pattern, option(expression));
/** doc attached */
type core_type = {
ptyp_desc: core_type_desc,
ptyp_loc: Location.t,
ptyp_attributes: attributes,
};
/** doc attached with newline */
type core_type = {
ptyp_desc: core_type_desc,
ptyp_loc: Location.t,
ptyp_attributes: attributes,
};
/** doc attached with newline and comments */
/* comment1 */
/* comment2 */
type core_type = {
ptyp_desc: core_type_desc,
ptyp_loc: Location.t,
ptyp_attributes: attributes,
};
/** doc attached */
type water +=
| H20
| Spritzer;
/** doc with newline */
type water +=
| H20
| Spritzer;
/** doc with newline and comment */
/* test */
type water +=
| H20
| Spritzer;
/** doc attached */
exception Key_not_found(string);
/** doc attached with newline */
exception Key_not_found(string);
/** doc attached with newline and comment */
/* comment */
exception Key_not_found(string);
/** doc on open */
open Belt;
/** doc on open with whitespace */
open Belt;
/** doc on open with whitespace and comment */
/* test */
open Belt;
/** doc attached */
include Shared;
/** doc attached with whitespace */
include Shared;
/** doc attached with whitespace and comment */
/* test */
include Shared;
/** doc attached */
module type X = {let x: int};
/** doc attached with whitespace */
module type X = {let x: int};
/** doc attached with whitespace and comment */
/* test */
module type X = {let x: int};
/** doc attached */
module X : MX;
/** doc attached with whitespace */
module X : MX;
/** doc attached with whitespace and comment */
/* test */
module X : MX;
/** doc attached */
module X = MX;
/** doc attached with whitespace */
module X = MX;
/** doc attached with whitespace and comment */
/* test */
module X = MX;
/** doc attr attached */
class type x = {
pub height: int
};
/** doc attr with newline */
class type x = {
pub height: int
};
/** doc attr with newline and comment */
/* test */
class type x = {
pub height: int
};
/** doc attr attached */
[@id];
/** doc attr with newline */
[@id];
/** doc attr with newline and comment */
/* test */
[@id];
/** doc attr attached */
[%%obj {a: 1}];
/** doc attr attached with newline */
[%%obj {a: 1}];
/** doc attr attached with newline and comment */
/* test */
[%%obj {a: 1}];
/** doc attached */
class reason : ocaml;
/** doc attached with whitespace */
class reason : ocaml;
/** doc attached with whitespace and comment */
/* test */
class reason : ocaml;
/** doc attached */
module rec X1: Y1
and X2: Y2;
/** doc attached with whitespace */
module rec X1: Y1
and X2: Y2;
/** doc attached with whitespace and comment */
/* comment */
module rec X1: Y1
and X2: Y2;
/** rec modules with whitespace */
/* -> */
module rec X1: Y1
and X2: Y2;
/** rec modules with whitespace and attrs */
/* -> */
[@foo]
module rec X1: Y1
/** another one below */
/* random comment */
[@bar]
and X2: Y2;
/* notice the whitespace after the last signature item */
/* this one has whitespace interleaved */
/* stick together */
/* :) */
================================================
FILE: test/whitespace-rei.t/run.t
================================================
Format whitespace in .rei files
$ refmt ./input.rei
/** Interleave whitespace intelligently in signatures */
/* a */
let a: int;
/** Hi I'm a doc comment for some_definition */
let some_definition:
(
~what_a_long_label: M.its_a_type,
~just_need_to_make_this: long_enough_to_wrap
) =>
unit;
/** Hi I'm a doc comment for another_definition */
let another_definition: unit => unit;
/* b */
let b: int;
/* trailing */
/* kkk */
/* ---> */
/* amazing */
let f: int => int;
/** stick to x */
type x = string;
/** one newline below */
type x = string;
/** one newline below with comment */
/* comment */
type x = string;
/** doc comment attached */
type payload =
| PStr(structure)
| PSig(signature)
| PTyp(core_type)
| PPat(pattern, option(expression));
/** doc comment with whitespace */
type payload =
| PStr(structure)
| PSig(signature)
| PTyp(core_type)
| PPat(pattern, option(expression));
/** doc comment with whitespace and comment below */
/* comment here */
type payload =
| PStr(structure)
| PSig(signature)
| PTyp(core_type)
| PPat(pattern, option(expression));
/** doc attached */
type core_type = {
ptyp_desc: core_type_desc,
ptyp_loc: Location.t,
ptyp_attributes: attributes,
};
/** doc attached with newline */
type core_type = {
ptyp_desc: core_type_desc,
ptyp_loc: Location.t,
ptyp_attributes: attributes,
};
/** doc attached with newline and comments */
/* comment1 */
/* comment2 */
type core_type = {
ptyp_desc: core_type_desc,
ptyp_loc: Location.t,
ptyp_attributes: attributes,
};
/** doc attached */
type water +=
| H20
| Spritzer;
/** doc with newline */
type water +=
| H20
| Spritzer;
/** doc with newline and comment */
/* test */
type water +=
| H20
| Spritzer;
/** doc attached */
exception Key_not_found(string);
/** doc attached with newline */
exception Key_not_found(string);
/** doc attached with newline and comment */
/* comment */
exception Key_not_found(string);
/** doc on open */
open Belt;
/** doc on open with whitespace */
open Belt;
/** doc on open with whitespace and comment */
/* test */
open Belt;
/** doc attached */
include Shared;
/** doc attached with whitespace */
include Shared;
/** doc attached with whitespace and comment */
/* test */
include Shared;
/** doc attached */
module type X = {
let x: int;
};
/** doc attached with whitespace */
module type X = {
let x: int;
};
/** doc attached with whitespace and comment */
/* test */
module type X = {
let x: int;
};
/** doc attached */
module X: MX;
/** doc attached with whitespace */
module X: MX;
/** doc attached with whitespace and comment */
/* test */
module X: MX;
/** doc attached */
module X = MX;
/** doc attached with whitespace */
module X = MX;
/** doc attached with whitespace and comment */
/* test */
module X = MX;
/** doc attr attached */
class type x = {
pub height: int;
};
/** doc attr with newline */
class type x = {
pub height: int;
};
/** doc attr with newline and comment */
/* test */
class type x = {
pub height: int;
};
/** doc attr attached */;
[@id];
/** doc attr with newline */;
[@id];
/** doc attr with newline and comment */;
/* test */
[@id];
/** doc attr attached */
[%%obj { a: 1 }];
/** doc attr attached with newline */
[%%obj { a: 1 }];
/** doc attr attached with newline and comment */
/* test */
[%%obj { a: 1 }];
/** doc attached */
class reason: ocaml;
/** doc attached with whitespace */
class reason: ocaml;
/** doc attached with whitespace and comment */
/* test */
class reason: ocaml;
/** doc attached */
module rec X1: Y1
and X2: Y2;
/** doc attached with whitespace */
module rec X1: Y1
and X2: Y2;
/** doc attached with whitespace and comment */
/* comment */
module rec X1: Y1
and X2: Y2;
/** rec modules with whitespace */
/* -> */
module rec X1: Y1
and X2: Y2;
/** rec modules with whitespace and attrs */
/* -> */
[@foo]
module rec X1: Y1
/** another one below */
/* random comment */
[@bar]
and X2: Y2;
/* notice the whitespace after the last signature item */
/* this one has whitespace interleaved */
/* stick together */
/* :) */
================================================
FILE: test/wrapping-re.t/input.re
================================================
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
/* Run the formatting pretty printer with width 50 */
/*
* Testing infix wrapping
*/
let reallyLongIdent = 100;
let andYetAnotherReallyLongIdent = 30;
let something =
reallyLongIdent +
andYetAnotherReallyLongIdent +
reallyLongIdent;
let something =
/* Hopefully */
reallyLongIdent +
/* It will indent like this */
andYetAnotherReallyLongIdent +
/* And no further */
reallyLongIdent;
/* Comments can be written like this.
No leading star is required on each line.
Everything will line up just fine.
In this form, include the final closing on the last line. */
let test = 10;
/* You could begin the block bar out like this.
And it still works correctly. */
let test = 10;
/** Include multiple opening stars if you like.
And it will still work. */
let test = 10;
/** This comment will be corrected.
when printed. */
let test = 10;
/** Comments with text on line zero
* Still work well with comments that have stars on the left side.
*/
let test = 10;
/*
* Even though the precedence of the operators are different, no
* "simplification" grouping is needed.
*/
let testPrintingPrecedence =
reallyLongIdent +
reallyLongIdent * andYetAnotherReallyLongIdent +
reallyLongIdent;
let testPrintingPrecedence =
reallyLongIdent +
/*
* In this case, grouping of the right expression is needed because the
* right side of the infix operator is of *lower* precedence than STAR.
*/
reallyLongIdent * (reallyLongIdent + andYetAnotherReallyLongIdent) +
(reallyLongIdent * 10);
let testPrintingPrecedence =
reallyLongIdent +
/*
* In this case, grouping of the right expression is needed because the
* right side of the infix operator is of *lower* precedence than STAR.
*/
reallyLongIdent * (reallyLongIdent + andYetAnotherReallyLongIdent) +
reallyLongIdent;
let add(x,y) = x + y;
let testPrintingPrecedence =
reallyLongIdent +
/*
* In this case, grouping of the right expression is needed because the
* right side isn't even infix at all.
*/
reallyLongIdent * add(reallyLongIdent,andYetAnotherReallyLongIdent) +
reallyLongIdent;
/*
* Test wrapping every form of named arguments where various parts are
* commented.
*/
let a = 10;
let b = 20;
/*A*/
let named
/* a::a */
(~a as a,
/* b::b */
~b as b) =
/* a + b */
a + b;
/*B*/
let namedAlias
/* a::aa */
(~a as aa,
/* b::bb */
~b as bb) =
/* aa + bb */
aa + bb;
/*C*/
let namedAnnot
/* ~a a: option(int) */
(~a as a: option(int),
/* ~b b: option(int) */
~b as b: option(int)) =
/* 20 */
20;
/*D*/
let namedAliasAnnot
/* a::(aa: option int) */
(~a as aa: option(int),
/* b::(bb: option int) */
~b as bb: option(int)) =
/* 20 */
20;
/*E*/
let optional
/* a::a=? */
(~a as a=?,
/* b::b=? */
~b as b=?,
/* () */
()) =
/* 10 */
10;
/*F*/
let optionalAlias
/* a::aa */
(~a as aa=?,
/* ?b:bb */
~b as bb=?,
/* () */
()) =
/* 10 */
10;
/*G*/
let optionalAnnot
/* a::(a: option int)=? */
(~a: option(int)=?,
/* ?b:(b: option int) */
~b: option(int)=?,
/* () */
()) =
/* 10 */
10;
/*H*/
let optionalAliasAnnot
/* a::(aa: option int)=? */
(~a as aa: option(int)=?,
/* b::(bb: option int)=? */
~b as bb: option(int)=?,
/* () = */
()) =
/* 10 */
10;
/*I: This one is really annoying? Where's the visual label?*/
let defOptional
/* a::a=10 */
(~a as a=10,
/* b::b=10 */
~b as b=10,
/* () = */
()) =
/* 10 */
10;
/*J*/
let defOptionalAlias
/* a::aa=10 */
(~a as aa=10,
/* b::bb=10 */
~b as bb=10,
/* () = */
()) =
/* 10; */
10;
/*K*/
let defOptionalAnnot
/* a::(a:int)=10 */
(~a :int=10,
/* b::(b:int)=10 */
~b :int=10,
/* () = */
()) =
/* 10; */
10;
/*L*/
let defOptionalAliasAnnot
/* a::(aa:int)=10 */
(~a as aa :int=10,
/* b::(bb:int)=10 */
~b as bb :int=10,
/* () = */
()) =
/* 10; */
10;
/* Invoking them */
named(
/* a::a */
~a=a,
/* b::b; */
~b=b
);
named(
/* a::a */
~a=a,
/* b::b; */
~b=b
);
optional(
/* a::a */
~a=a,
/* b::b; */
~b=b
);
optional(
/* a::a */
~a=a,
/* b::b; */
~b=b
);
let explictlyPassed =
/* optional */
optional(
/* a::? */
~a=?
/* None */
None,
/* b::? */
~b=?
/* None; */
None
);
let a = None;
let explictlyPassed =
/* optional */
optional(
/* a::? */
~a=?a,
/* b::? */
~b=?
/* None; */
None);
let complex_default(~callback as callback=(fun(k,d) => 4),x) = 3;
let myList = /*CommentAfterEqualBeforeList */[1, 2, 3];
let myList = [/*CommentAfterEqualBefore1 */1, 2, 3];
let myList = [1 /*CommentAfterOneBeforeCons */, 2, 3];
let myList = [1, 2 /*CommentAfterTwoBeforeCons */, 3, ];
let myList = [1, 2, /*CommentAfterConsBeforeThree */3 ];
let myList = [1, 2, 3/*CommentAfterThreeBeforeCons*/];
let myList = [1, 2, 3 /*same w space after three */];
let myList = [1, 2, 3/*same w space before rbracket*/ ];
let myList = [1, 2, 3 /*same w both */ ];
/* End of line comments */
let myList = [
1,
2,
3/*no space after three */
];
let myList = [
1,
2,
3 /*same w space after three */
];
let myList = [
1,
2,/*no space after two comma */
3
];
let myList = [
1,
2, /*same w space after two comma */
3
];
/* End of line comments */
let myList = [
1,
2,/*no space after two comma */
3
];
let myList = [
1,
2, /*same w space after two comma */
3
];
let myRec = {
x:1,
y:2,/*no space after two */
z:3
};
let myRec = {
x:1,
y:2, /*same w space after two */
z:3
};
/* Ensure end of line comments force breaks */
let myList = [
1,
2,
3/* */
];
let myList = [
1,
2,/**/
3
];
let myList = [1, 2, 3, /*CommentAfterConsBeforeAppendedTo */...myList];
let myList = [3, 4, 5];
let simpleListPattern(x) = switch (x) {
| [1, 2, 3] => 0
| _ => 0
};
type blahType = string;
let x: blahType = "asdf";
type nameAge = {
age: int,
name: string
};
type hasABunch = {
/*
* Field comment
*/
fieldOne: int,
fieldtwo: list(int),
fieldThree: list(string),
fieldFour: nameAge
/* Comment at bottom of record type def */
};
type functionsInARecord = {
adder: (int) => int,
minuser: (int) => int
};
let myFunctionsInARecord = {
adder: fun(x) => x,
minuser: fun(x) => x
};
let myFunctionsInARecordThatMustWrap = {
/* Desired wrapping */
adder:
fun(reallyLongArgument) => reallyLongArgument,
minuser:
fun(anotherReallyLongArgument) => anotherReallyLongArgument
/* Comment at bottom of record */
};
type twoArgFunctionsInARecord = {
adder: (int, int) => int,
minuser: (int, int) => int
};
let myFunctionsInARecordThatMustWrap = {
/* Desired wrapping */
adder:
fun(reallyLongArgument,
anotherReallyLongArgument) =>
reallyLongArgument,
minuser:
fun(reallyLongArgument,
anotherReallyLongArgument) =>
reallyLongArgument + anotherReallyLongArgument,
};
type threeArgFunctionsInARecord = {
adder: (int, int, int) => int,
minuser: (int, int, int) => int
};
let myFunctionsInARecordThatMustWrap = {
/* Desired wrapping */
adder:
/* Even if you have a comment before fun */
fun(reallyLongArgument,
/* Or before the first arg */
anotherReallyLongArgument,
yetAnotherReallyLongArgument) =>
reallyLongArgument,
minuser:
fun(reallyLongArgument,
anotherReallyLongArgument,
anotherReallyLongArgument) =>
reallyLongArgument + anotherReallyLongArgument,
};
let oneArgShouldWrapToAlignWith
(theFunctionNameBinding) = theFunctionNameBinding;
let twoArgsShouldWrapToAlignWith
(firstArgHere,
secondArgThere) = secondArgThere;
let rec oneArgShouldWrapToAlignWith
(theFunctionNameBinding) = theFunctionNameBinding;
let rec twoArgsShouldWrapToAlignWith
(firstArgHere,
secondArgThere) = secondArgThere;
let secondArgShouldWrap (pointLess, (
a,
b,
c,
d,
e,
f,
g,
h
)) = (
pointLess + a + b + c + d + e
);
/* Now check that one and two args both indent the same when applying */
let reallyReallyLongVarName = "hello";
let result =
oneArgShouldWrapToAlignWith
(reallyReallyLongVarName);
let result =
twoArgsShouldWrapToAlignWith
(reallyReallyLongVarName,
reallyReallyLongVarName);
let justReturn(x) = x;
/* With default formatting settings: Two arguments are special cased in
function application "justReturn hasABunch" */
let acceptsTwoThings
(nameAge:nameAge,
hasABunch:hasABunch) = justReturn(hasABunch);
/*
Ideally, we'd allow "acceptsTwoThings {age, name}" on the first line, then
wrapping the final argument across multiple, but that is difficult to tell
the formatter "if the final argument cannot fit", but everything else can,
then only wrap the final argument with open faced braces. It's possible, but
not a v1 feature of wrapping.
*/
let result =
acceptsTwoThings
{age:20, name:"a"}
{
fieldOne: 10,
fieldtwo: [10, 20],
fieldThree: ["one", "two"],
fieldFour: {age: 20, name: "joe"}
};
let howDoesInfixOperatorsWrapWhenYouMustWrapQuestionMark(x,y,z) = x + y + z;
let howDoesInfixOperatorsWrapWhenYouMustWrapQuestionMark(x,y) = x + y;
let reallyHowDoesInfixOperatorsWrapWhenYouMustWrapQuestionMark(x,y,z) = x + y + z;
let reallyHowDoesInfixOperatorsWrapWhenYouMustWrapQuestionMark(x,y) = x + y;
let reallyLongFunctionNameThatJustConcats(a) = String.concat("-",a);
let seeHowLongValuesWrap = {
age: 30,
name: reallyLongFunctionNameThatJustConcats([
"one",
"two",
"two",
"two",
"two",
"two",
"two"
])
};
/*
/--Everything up to the arrow is label left--\ /-The return is label right-\
/-append => to last-\
/-----------------------\ /--------------------\ */
let onlyReturnWraps ((a, b, c, d, e, f)) = (
a,
b,
c,
d,
e,
f
);
let bothArgsWrapAndIndent
((a, b, c, d, e, f),
(h, i, j, k, l, m)) = (
a,
b,
c,
d,
e,
f
);
let result = onlyReturnWraps ((
10,
11,
12,
13,
14,
15
));
let result =
bothArgsWrapAndIndent
((10, 11, 12, 13, 14, 15),
(10, 11, 12, 13, 14, 15));
type sixteenTuple = (int, int, int, int, int, int, int, int, int, int, int, int, int, int, int, int);
/* Nothing annotated */
let echoTuple ((
a,
b,
c,
d,
e,
f,
g,
h,
i,
j,
k,
l,
m,
n,
o,
p
)) = (
a,
b,
c,
d,
e,
f,
g,
h,
i,
j,
k,
l,
m,
n,
o,
p
);
/* Nothing annotated fun */
let echoTuple = fun((a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p)) => (
a,
b,
c,
d,
e,
f,
g,
h,
i,
j,
k,
l,
m,
n,
o,
p
);
let echoTheEchoer (x: (sixteenTuple) => sixteenTuple) : (sixteenTuple) => sixteenTuple = x;
/* Nothing annotated fun, passed to func */
echoTheEchoer (fun((a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p)) => (
a,
b,
c,
d,
e,
f,
g,
h,
i,
j,
k,
l,
m,
n,
o,
p
));
/* Argument annotated */
let echoTuple ((a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p):sixteenTuple) = (
a,
b,
c,
d,
e,
f,
g,
h,
i,
j,
k,
l,
m,
n,
o,
p
);
/* Argument annotated fun */
let echoTuple = fun ((a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p):sixteenTuple) => (
a,
b,
c,
d,
e,
f,
g,
h,
i,
j,
k,
l,
m,
n,
o,
p
);
/* Argument annotated, return type annotated */
let echoTuple ((a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p):sixteenTuple) :sixteenTuple = (
a,
b,
c,
d,
e,
f,
g,
h,
i,
j,
k,
l,
m,
n,
o,
p
);
/* Desired formatting if first line fits within margin */
let makeTuple(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) = (
a,
b,
c,
d,
e,
f,
g,
h,
i,
j,
k,
l,
m,
n,
o,
p
);
/* Desired formatting if first line fits within margin (70) */
let (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) =
makeTuple(0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
/* Annotated version */
let (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p): sixteenTuple =
makeTuple(0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
/* Annotated inline */
let x: (int, int, int, int, int, int, int, int, int, int, int, int, int, int, int, int) =
makeTuple(0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
let (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) =
echoTuple((0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0));
/* Annotated version */
let (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p): sixteenTuple =
echoTuple((0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0));
/* Annotated inline */
let x: (int, int, int, int, int, int, int, int, int, int, int, int, int, int, int, int) =
echoTuple((0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0));
/* Desired formatting if pattern does not fit, arguments do (margin 70) */
/* Destructured */
let (
axx,
bxx,
cxx,
dxx,
exx,
fxx,
gxx,
hxx,
ixx,
jxx,
kxx,
lxx,
mxx,
nxx,
oxx,
pxx
) = makeTuple(0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
/* Annotated */
/* Destructured */
let (
axx,
bxx,
cxx,
dxx,
exx,
fxx,
gxx,
hxx,
ixx,
jxx,
kxx,
lxx,
mxx,
nxx,
oxx,
pxx
): sixteenTuple = makeTuple(0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
/* Annotated */
/* Destructured */
/* Inline */
let (
axx,
bxx,
cxx,
dxx,
exx,
fxx,
gxx,
hxx,
ixx,
jxx,
kxx,
lxx,
mxx,
nxx,
oxx,
pxx
): (int, int, int, int, int, int, int, int, int, int, int, int, int, int, int, int) = makeTuple(0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
/* Not-Destructured */
let someResult = makeTuple(0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
/* Annotated */
/* Not-Destructured */
let someResult: sixteenTuple = makeTuple(0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
/* Annotated */
/* Not-Destructured */
/* Inline */
let someResult: (int, int, int, int, int, int, int, int, int, int, int, int, int, int, int, int) = makeTuple(0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
/* Destructured */
let (
axx,
bxx,
cxx,
dxx,
exx,
fxx,
gxx,
hxx,
ixx,
jxx,
kxx,
lxx,
mxx,
nxx,
oxx,
pxx
) = echoTuple((0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0));
/* Annotated */
let (
axx,
bxx,
cxx,
dxx,
exx,
fxx,
gxx,
hxx,
ixx,
jxx,
kxx,
lxx,
mxx,
nxx,
oxx,
pxx
): sixteenTuple = echoTuple((0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0));
/* Annotated Inline */
let (
axx,
bxx,
cxx,
dxx,
exx,
fxx,
gxx,
hxx,
ixx,
jxx,
kxx,
lxx,
mxx,
nxx,
oxx,
pxx
): (int, int, int, int, int, int, int, int, int, int, int, int, int, int, int, int) = echoTuple((0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0));
/* Not-Destructured */
let someResult = echoTuple((0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0));
/* Annotated */
/* Not-Destructured */
let someResult: sixteenTuple = echoTuple((0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0));
/* Annotated Inline */
/* Not-Destructured */
let someResult: (int, int, int, int, int, int, int, int, int, int, int, int, int, int, int, int) = echoTuple((0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0));
/* Desired formatting if neither fit on one line (margin 70) */
/* Destructured */
let (
axx,
bxx,
cxx,
dxx,
exx,
fxx,
gxx,
hxx,
ixx,
jxx,
kxx,
lxx,
mxx,
nxx,
oxx,
pxx
) =
makeTuple
(axx,
bxx,
cxx,
dxx,
exx,
fxx,
gxx,
hxx,
ixx,
jxx,
kxx,
lxx,
mxx,
nxx,
oxx,
pxx);
/* Annoted */
let (
axx,
bxx,
cxx,
dxx,
exx,
fxx,
gxx,
hxx,
ixx,
jxx,
kxx,
lxx,
mxx,
nxx,
oxx,
pxx
): sixteenTuple =
makeTuple
(axx,
bxx,
cxx,
dxx,
exx,
fxx,
gxx,
hxx,
ixx,
jxx,
kxx,
lxx,
mxx,
nxx,
oxx,
pxx);
/* Annoted inline */
let (
axx,
bxx,
cxx,
dxx,
exx,
fxx,
gxx,
hxx,
ixx,
jxx,
kxx,
lxx,
mxx,
nxx,
oxx,
pxx
): (int, int, int, int, int, int, int, int, int, int, int, int, int, int, int, int) =
makeTuple
(axx,
bxx,
cxx,
dxx,
exx,
fxx,
gxx,
hxx,
ixx,
jxx,
kxx,
lxx,
mxx,
nxx,
oxx,
pxx);
/* Not-Destructured */
let someResult =
makeTuple
(axx,
bxx,
cxx,
dxx,
exx,
fxx,
gxx,
hxx,
ixx,
jxx,
kxx,
lxx,
mxx,
nxx,
oxx,
pxx);
/* Not-Destructured */
/* Annoted */
let someResult: sixteenTuple =
makeTuple
(axx,
bxx,
cxx,
dxx,
exx,
fxx,
gxx,
hxx,
ixx,
jxx,
kxx,
lxx,
mxx,
nxx,
oxx,
pxx);
/* Not-Destructured */
/* Annoted inline */
let someResult: (int, int, int, int, int, int, int, int, int, int, int, int, int, int, int, int) =
makeTuple
(axx,
bxx,
cxx,
dxx,
exx,
fxx,
gxx,
hxx,
ixx,
jxx,
kxx,
lxx,
mxx,
nxx,
oxx,
pxx);
/* Desired formatting if neither fit on one line (margin 70) */
/* Destructured */
let (
axx,
bxx,
cxx,
dxx,
exx,
fxx,
gxx,
hxx,
ixx,
jxx,
kxx,
lxx,
mxx,
nxx,
oxx,
pxx
) = echoTuple ((
1000,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10
));
/* Annoted */
/* Destructured */
let (
axx,
bxx,
cxx,
dxx,
exx,
fxx,
gxx,
hxx,
ixx,
jxx,
kxx,
lxx,
mxx,
nxx,
oxx,
pxx
): sixteenTuple = echoTuple ((
1000,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10
));
/* Annoted Inline */
/* Destructured */
let (
axx,
bxx,
cxx,
dxx,
exx,
fxx,
gxx,
hxx,
ixx,
jxx,
kxx,
lxx,
mxx,
nxx,
oxx,
pxx
): (int, int, int, int, int, int, int, int, int, int, int, int, int, int, int, int) = echoTuple ((
1000,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10
));
/* Desired formatting if neither fit on one line (margin 70) */
/* Not-Destructured */
let someResult = echoTuple ((
1000,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10
));
/* Annoted */
/* Not-Destructured */
let someResult: sixteenTuple = echoTuple ((
1000,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10
));
/* Annoted Inline */
/* Not-Destructured */
let someResult: (int, int, int, int, int, int, int, int, int, int, int, int, int, int, int, int) = echoTuple ((
1000,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10
));
/* The rhs of = shouldn't be broken onto its own newline: @see ensureSingleTokenSticksToLabel */
let someResult: (
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int
) = someResult;
type sevenStrings = (string, string, string, string, string, string, string);
let (only, the, type_, should, have, to_, wrap) = (
"only",
"the",
"type",
"should",
"have",
"to",
"wrap"
);
let (only, the, type_, should, have, to_, wrap):sevenStrings = (
"only",
"the",
"type",
"should",
"have",
"to",
"wrap"
);
let ifTheNameIsReallyLongTheTypeAndValueShouldBothWrap: (string, string, string, string, string, string, string) = (
"only",
"the",
"type",
"should",
"have",
"to",
"wrap"
);
let (the, type_, and_, value, should, both, wrap): (string, string, string, string, string, string, string) = (
"but",
"the",
"destructured",
"assignment",
"should",
"not",
"wrap"
);
let myPolyFunc: 'a . ('a) => 'a = fun(o) => o;
let myNonPolyFunc: ('a) => 'a = fun(o) => o;
let locallyAbstractFunc (type a, input:a) = input;
let locallyAbstractFuncNotSugared = fun (type a, input:a) => input;
let locallyAbstractFuncAnnotated: type a. (a) => a = fun (type a, input:a) => input;
/*
Examples of how long versions of these should be wrapped: df stands for
"desired formatting" when the function binding itself must wrap.
*/
let df_myPolyFunc: 'a . ('a) => 'a = fun(o) => o;
let df_myNonPolyFunc: ('a) => 'a = fun(o) => o;
type nameBlahType = {nameBlah: int};
let myFunc =
fun(~firstArg as firstArg,
~another as another,
~fl as fl) => {
nameBlah: 10
};
type inputEchoRecord('a) = {
inputIs: 'a
};
let df_locallyAbstractFunc
(type a,
type b,
input:a) {
inputIs: input
}; /* With setting ReturnValOnSameLine */
let df_locallyAbstractFuncNotSugared =
fun (type a,
type b,
input:a) {
inputIs: input
};
/**
* The following is automatically expanded at the parser level into:
*
* let df_locallyAbstractFuncAnnotated:
* 'a .
* 'a => 'a => inputEchoRecord 'a
* =
* fun (type a) => (
* fun (input: a) (input: a) => {inputIs: input}:
* a => a => inputEchoRecord a
* );
*
*/
let df_locallyAbstractFuncAnnotated: type a. (a, a) => inputEchoRecord(a) =
fun (input:a, input:a) {
inputIs: input
};
/**
* The following is automatically expanded at the parser level into:
*
* let df_locallyAbstractFuncAnnotated:
* 'a .
* 'a => 'a => inputEchoRecord 'a
* =
* fun (type a) => (
* df_locallyAbstractFuncAnnotated:
* a => a => inputEchoRecord a
* );
*
*/
let df_locallyAbstractFuncAnnotatedRef: type a. (a, a) => inputEchoRecord(a) =
df_locallyAbstractFuncAnnotated;
/**
* Doesn't do what you want:
*
* let df_locallyAbstractFuncAnnotatedExtra: type a. a => a => inputEchoRecord a =
* fun (type a)
* (input:a)
* (input:a) => {
* inputIs: input
* };
*/
/**
* The following is automatically expanded at the parser level into:
*
* let df_locallyAbstractFuncAnnotatedTwo:
* 'a 'b .
* 'a => 'b => (inputEchoRecord 'a, inputEchoRecord 'b)
* =
* fun (type a) (type b) => (
* fun (input: a) (input2: b) => ({inputIs: input}, {inputIs:input2}):
* a => b => (inputEchoRecord a, inputEchoRecord b)
* );
*
*/
let df_locallyAbstractFuncAnnotated: type a b. (a, b) => (inputEchoRecord(a), inputEchoRecord(b)) =
fun (input:a, input2:b) => (
{inputIs: input},
{inputIs: input2}
);
/**
* This case shows why inferring what was originally sugar type a b . blahblah
* is not so trivial. We have to take the last Pexp_constraint type, varify the
* constructors, then check if the result is equal to the first
* Ppat_constraint. In this case, they're not equal!
*/
let df_locallyAbstractFuncAnnotated:
'figureMeOut
=
fun (type a, type b) => (
fun (input: a, input2: b) => (
{inputIs: input},
{inputIs: input2}
):
(a, b) => (inputEchoRecord(a), inputEchoRecord(b))
);
let createTuple_thisFuncShouldWrapCorrectlyNow
:'a. ('a, 'a, 'a) => ('a, 'a, 'a) =
(someVar,someVar2,someVar3) => (someVar, someVar2, someVar3);
let (theTupleTypeAnnotationShouldWrap: (
string,
string,
string,
string
)) = (
"now these tuple values should wrap",
"now these tuple values should wrap",
"now these tuple values should wrap",
"now these tuple values should wrap"
);
let rec mutuallyRecursiveOne(x) = mutuallyRecursiveTwo (x + x)
and mutuallyRecursiveTwo(y) = print_int(y);
/* The only downside to this is that now you can't redeclare a binding. */
/* let newMutualRecursionSyntax x => newMutuallyRecursiveTwo (x + x); */
/* let newMutuallyRecursiveTwo y => print_int y; */
/* */
type x = pri int;
type y = x = ..;
type myType('a,'b,'c) = pri ('a, 'b, 'c);
type privateVariant = pri
| BigSize(int)
| SmallSize(int);
type doubleEqualsDoublePrivateVariant =
privateVariant =
pri
| BigSize(int)
| SmallSize(int);
type myRecordWithReallyLongName = {xx:int, yy:int};
type doubleEqualsRecord = myRecordWithReallyLongName = {xx:int, yy:int};
type doubleEqualsDoublePrivateRecord = myRecordWithReallyLongName = pri {xx:int, yy:int};
type someConstructor = SomeConstructorHi(int,int);
type someRecord = {firstFieldInRecord: int, secondField: int};
/*
With settings.functionBindingStyle = AttachFirstTermToLabelIffTwoTotalTerms,
the binding name becomes part of the label when there are only two total
terms in the binding/argument pattern list (the name, followed by one
pattern).
*/
let funcOnSomeConstructorHi (
SomeConstructorHi(x,y)
) = x + y;
let funcOnSomeConstructorHi
(SomeConstructorHi(x,y),
secondArg) = x + y;
/* With two args */
let funcOnSomeRecord ({
firstFieldInRecord,
secondField
}) = firstFieldInRecord + secondField;
let funcOnSomeRecord
({firstFieldInRecord, secondField}, secondArg) =
firstFieldInRecord + secondField;
/*
With settings.functionBindingStyle = DontAttachFirstTermToLabel,
the binding name becomes part of the label when there are only two total
terms in the binding/argument pattern list (the name, followed by one
pattern).
*/
let funcOnSomeConstructorHi
(SomeConstructorHi(x,y)) = x + y;
let funcOnSomeRecord
({firstFieldInRecord, secondField}) =
firstFieldInRecord + secondField;
/* With two args */
let funcOnSomeConstructorHi
(SomeConstructorHi(x,y), secondArg) =
x + y;
let funcOnSomeRecord
({firstFieldInRecord, secondField}, secondArg) =
firstFieldInRecord + secondField;
type simpleTupleVariant =
SimpleActuallyATuple((int, int));
let returnTheSimpleTupleVariant(i) =
SimpleActuallyATuple (i, i);
let shouldWrapLike(whenLongArg) = SimpleActuallyATuple (
whenLongArg,
whenLongArg
);
type recordWithLong = {
someField: int,
anotherField: string
};
/*
* Commenting first of two mutualy recursive types.
*/
type recursiveType =
/* First variant of first mutually recursive */
| Blah
/* Second variant of first mutually recursive */
| Another (option(anotherRecursiveType))
/*
* Commenting second of two mutually recursive types.
*/
and anotherRecursiveType =
/* Second variant of second mutually recursive */
| Baz
/* Second variant of second mutually recursive */
| Recursive (option(recursiveType));
/**
* Commented GADT definition.
*/
type term(_) =
/* First variant leaf of GADT */
| Int /*first var arg */ (int) : /* First GADT res */ term(int)
/* Second variant leaf of GADT */
| Float /*second var arg */ (int) : /* Second GADT res */ term(int)
/* Third variant leaf of GADT */
| Bool /*third var arg */ (int) : /* Third GADT res */ term(int);
/* Commented colors */
type commentedTypeDef =
/*
* Commenting first variant member.
*/
| First ((
/* First field of tuple in first variant member */
int,
/* Second field of tuple in first variant member */
int
))
/*
* Commenting second variant member.
*/
| Second(int)
/*
* Commenting third variant member.
*/
| Third (
list
/* Commenting deep in type def */
(list(int))
);
type colors =
| Red(int)
| Black(int)
| Green(int);
let blah = fun(arg) => switch (arg) {
/* Comment before Bar */
| /* Comment between bar/pattern */
Red(_) => 1
/* Comment Before non-first bar */
| /* Comment betwen bar/pattern */
Black(_) => 0
| Green(_) => 0
};
let blah = fun
| Red(_) => 1
| Black(_) => 0
| Green(_) => 1;
let blahCurriedX(x) = fun
/* Comment before first bar */
| /* Comment between first bar and OR pattern */
(Red(x) | Black(x) | Green(x)) => 1
/* Comment before second bar */
| Black(x) => 0
| Green(x) => 0;
type reallyLongVariantNames =
| ReallyLongVariantName(recordWithLong)
| AnotherReallyLongVariantName(int,int,int)
| AnotherReallyLongVariantName2(int,int,int);
let howDoLongMultiBarPatternsWrap = fun(x) => switch (x) {
| AnotherReallyLongVariantName(_,_,_) => 0
| AnotherReallyLongVariantName2(_,_,_) => 0
| ReallyLongVariantName {someField, anotherField} => 0
};
let letsCombineTwoLongPatternsIntoOneCase(x) =
switch (x) {
| AnotherReallyLongVariantName(_,_,_)
| AnotherReallyLongVariantName2(_,_,_) => 0
| ReallyLongVariantName {someField, anotherField} => 0
};
let letsPutAWhereClauseOnTheFirstTwo(x) =
switch (x) {
| AnotherReallyLongVariantName(_,_,_)
| AnotherReallyLongVariantName2(_,_,_) when true => 0
| ReallyLongVariantName {someField, anotherField} => 0
};
let letsPutAWhereClauseOnTheLast(x) =
switch (x) {
| AnotherReallyLongVariantName(_,_,_)
| AnotherReallyLongVariantName2(_,_,_) => 0
| ReallyLongVariantName {someField, anotherField} when true => 0
};
type wrappingGadt(_) =
| ThisIsLongSoTypeWillWrap(int)
:wrappingGadt(int)
| Add :wrappingGadt ((int, int) => int)
| App
(wrappingGadt(('b) => 'a), wrappingGadt('b))
:wrappingGadt('a);
type withThreeFields = {
name: string,
age: int,
occupation: string
};
let testRecord = {
name: "joe",
age: 20,
occupation: "engineer"
};
let anotherRecord = {
...testRecord,
name: "joe++",
age: testRecord.age + 10
};
type polymorphicCommentedType
/* Commenting the first type variable */
('a,
/* Commenting the second type variable */
'b) = list ('a, 'b);
/**
* Commenting the entire record definition.
*/
type withThreeFieldsCommented = {
/* Commenting the first field */
nameCommented: string,
/* Commenting the second field */
ageCommented: int,
/* Commenting the third field */
occupationCommented: string
};
/**
* Commenting the entire record.
*/
let testRecordCommented = {
/* Commenting the first field */
nameCommented: "joe",
/* Commenting the second field */
ageCommented: 20,
/* Commenting the last field */
occupationCommented: "engineer"
};
/*
* Test comments near the arguments.
*/
let callMeWithComments
/* Comment before first arg "a" */
(a:int,
/* Comment before second arg "b" */
b:int)
/* Comment before return type annotation "int" */
:int =
/* Comment above return value a + b + c */
a + b + c;
let callMeWithComments2 =
/* Comment before the only argument */
((a:int,
/* Comment before second arg "b" */
b:int))
/* Comment before return type annotation "int" */
:int =>
/* Comment above return value a + b + c */
a + b + c;
let result =
/* Comment before function to invoke */
callMeWithComments
/* Comment before first argument expression */
(1 + 2 + 3 + 3,
/* Comment before second argument expression */
1 + 2 + 3 + 3);
module type ASig = {let a:int;};
module type BSig = {let b:int;};
module AMod = {let a = 10;};
module BMod = {let b = 10;};
module CurriedSugar
/* Commenting before First curried functor arg */
/* If these comments aren't formatted correctly
* see how functor args' locations aren't set
* correclty due to the fold_left.
*/
(A:ASig,
/* Commenting before Second curried functor arg */
B:BSig) {
let result = A.a + B.b;
/* Comment at bottom of module expression */
};
module CurriedSugarFunctorResult =
/* Commenting before functor name*/
CurriedSugar
/* Commenting before functor arg 1 in app */
(AMod,
/* Commenting before functor arg 2 in app */
BMod);
module CurriedSugarFunctorResultInline =
/* Commenting before functor name*/
CurriedSugar
/* Commenting before functor arg 1 in app */
{let a=10;}
/* Commenting before functor arg 2 in app */
{let b=10;};
module type FunctorType = (ASig, ASig, BSig,) => BSig;
/*
* Commenting locations
*/
let commentingBeforeEqual /*beforeEqual*/ = {
name: "hello",
age: 20,
occupation: "programmer"
};
let commentingAfterEqual = /*afterEqual*/ {
name: "hello",
age: 20,
occupation: "programmer"
};
let commentingBeforeEqualBeforeType /*beforeEqualBeforeType*/ : withThreeFields = {
name: "hello",
age: 20,
occupation: "programmer"
};
let commentingBeforeEqualAfterType : withThreeFields /*beforeEqualAfterType*/ = {
name: "hello",
age: 20,
occupation: "programmer"
};
let commentingAfterEqualAfterType : withThreeFields = /*afterEqual*/ {
name: "hello",
age: 20,
occupation: "programmer"
};
let /*beforePattern*/ commentingBeforePattern : withThreeFields = {
name: "hello",
age: 20,
occupation: "programmer"
};
let /*beforePattern*/ /*beforePattern2 */ commentingBeforePattern2 : withThreeFields = {
name: "hello",
age: 20,
occupation: "programmer"
};
let /*beforePattern*/ /*beforePattern2 */ commentingBeforePatternSpecial : withThreeFields = {
name: "hello",
age: 20,
occupation: "programmer"
};
let produceRecord /*commentBeforeArg*/(x) {
name: "hello",
age: 20,
occupation: "programmer"
};
let produceRecord(x) /*commentAfterArg*/ {
name: "hello",
age: 20,
occupation: "programmer"
};
let myPolyFuncCommentBeforeColon /*beforeColon */: 'a . ('a) => 'a = fun(o) => o;
let myPolyFuncCommentAfterColon : /*afterColon */ 'a . ('a) => 'a = fun(o) => o;
let myPolyFuncCommentBeforeArrow : 'a . ('a) /*beforeArrow */ => 'a = fun(o) => o;
let myPolyFuncCommentAfterArrow : 'a . ('a) => /*afterArrow */ 'a = fun(o) => o;
/* THIS IS THE ONLY TEST THAT IS FAILING DUE TO BEING NON-IDEMPOTENT */
/* let myPolyFuncCommentBeforeEqual : 'a . ('a) => 'a /*beforeEqual */ = fun(o) => o; */
let myPolyFuncCommentAfterEqual : 'a . ('a) => 'a = /*afterEqual */ fun(o) => o;
let myNonPolyFuncCommentBeforeColon /*BeforeColon */: ('a) => 'a = fun(o) => o;
let myNonPolyFuncCommentAfterColon : /*AfterColon */('a) => 'a = fun(o) => o;
let myNonPolyFuncCommentBeforeArrow: ('a) /*BeforeArrow */=> 'a = fun(o) => o;
let myNonPolyFuncCommentAfterArrow: ('a) => /*AfterArrow */'a = fun(o) => o;
let myNonPolyFuncCommentBeforeEqual: ('a) => 'a /*BeforeEqual */= fun(o) => o;
let myNonPolyFuncCommentAfterEqual: ('a) => 'a = /*AfterEqual */ fun(o) => o;
let lATCurrySugarCommentBeforeType /*BeforeType */ (type a, input:a) = input;
let lATCurrySugarCommentAfterType /*AfterType */ (type a, input:a) = input;
let lATCurrySugarCommentBeforeArg (type a, /*BeforeArg */ input:a) = input;
let lATCurrySugarCommentAfterArg (type a, input:a) /*AfterArg */ = input;
let lATCurrySugarCommentAfterArrow (type a, input:a) = /*AfterArrow */ input;
let lATNotSugaredCommentBeforeEqual /*BeforeEqual*/ = fun (type a, input:a) => input;
let lATNotSugaredCommentAfterEqual = /*AfterEqual*/fun (type a, input:a) => input;
let lATNotSugaredCommentBeforeType = fun /*BeforeType*/(type a, input:a) => input;
let lATNotSugaredCommentAfterType = fun (type a /*AfterType*/, input:a) => input;
let lATNotSugaredCommentBeforeArg = fun (type a, /*BeforeArg*/ input:a) => input;
let lATNotSugaredCommentAfterArg = fun (type a, input:a) /*AfterArg*/ => input;
let lATNotSugaredCommentAfterArrow = fun (type a, input:a) => /*AfterArrow*/ input;
let lAtFuncAnnotatedCommentBeforeColon /*BeforeColon*/: type a. (a) => a = fun (type a, input:a) => input;
let lAtFuncAnnotatedCommentAfterColon: /*AfterColon*/ type a. (a) => a = fun (type a, input:a) => input;
let lAtFuncAnnotatedCommentBeforeTypeVar: type /*BeforeTypeVar*/ a. (a) => a = fun (type a, input:a) => input;
let lAtFuncAnnotatedCommentAfterTypeVar: type a /*AfterTypeVar*/. (a) => a = fun (type a, input:a) => input;
let lAtFuncAnnotatedBeforeEqual: type a. (a) => a /*BeforeEqual*/ = fun (type a, input:a) => input;
let lAtFuncAnnotatedAfterEqual: type a. (a) => a = /*AfterEqual*/ fun (type a, input:a) => input;
/* Ternary wrapping comments */
let ternaryResult =
/* Before Test */
something ?
/* Before ifTrue */
callThisFunction(withThisArg):
/* Before ifFalse */
thatResult;
let ternaryResult =
/* Before Test */
something ?
/* Before ifTrue */
callThisFunction(withThisArg):
/* Before ifFalse */
trailingTest ? /* before nested ifTrue */ true : /* before nested ifFalse */ false;
let returningATernary(x,y) = x > y ? "hi" : "by";
/** Testing some special comment alignment features */
/* Comments can be written like this.
No leading star is required on each line.
Everything will line up just fine.
In this form, include the final closing on the last line. */
let test = 10;
let test =
/* And if the entire block needs to be re-indented
such as this case, everything will still look okay. */
10;
/* You could begin the block bar out like this.
And it still works correctly. */
let test = 10;
/** Include multiple opening stars if you like.
And it will still work. */
let test = 10;
/** This comment will be corrected.
when printed. */
let test = 10;
/** Comments with text on line zero
* Still work well with comments that have stars on the left side.
*/
let test = 10;
let test =
/* This kind of comment doesn't exactly render well though.
Not many people write comments like this.
*/
10;
let x = calWith(
reallyLongName,
reallyReallyLongName,
reallyReallyLongName,
reallyReallyLongName,
reallyReallyLongName,
reallyReallyLongName,
a,
a,
a,
alskdjfalskdjfalsdf) + reallyReallyLongName;
let onlyDoingThisTopLevelLetToBypassTopLevelSequence = {
let x = {
print_int(1);
print_int(20); /* Missing trailing SEMI */
};
let x = {
print_int(1);
print_int(20); /* Ensure missing middle SEMI reported well */
print_int(20);
};
let x = {
print_int(1);
print_int(20);
10;
}; /* Missing final SEMI */
let x = {
print_int(1);
print_int(20);
10;
};
x + x; /* Final item */
};
/* With this unification, anywhere eyou see `= fun` you can just ommit it */
let blah = fun(a)=> a; /* Done */
let blah(a) = a; /* Done (almost) */
let blah = fun(a,b) => a; /* Done */
let blah(a,b) = a; /* Done (almost) */
let tryingTheSameInLocalScope = {
let blah = fun(a) => a; /* Done */
let blah(a) = a; /* Done (almost) */
let blah = fun(a,b) => a; /* Done */
let blah(a,b) = a; /* Done (almost) */
};
reallyLongFunctionNameWithArrayThatBreaks([|
"one",
"two",
"two",
"two",
"two",
"two",
"two"
|]);
reallyLongFunctionNameWithRecordStringKeys({
"one": 2345,
"two": 2345678,
"three": 45678,
"four": 45678
});
fooSpreadES6List([
"sldkjfklsjdflskjdflksjok",
"more tests",
...x
]);
let { foo: (_: int), } = 2;
================================================
FILE: test/wrapping-re.t/run.t
================================================
Format wrapping in .re files
$ refmt ./input.re
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
/* Run the formatting pretty printer with width 50 */
/*
* Testing infix wrapping
*/
let reallyLongIdent = 100;
let andYetAnotherReallyLongIdent = 30;
let something =
reallyLongIdent
+ andYetAnotherReallyLongIdent
+ reallyLongIdent;
let something =
/* Hopefully */
reallyLongIdent
/* It will indent like this */
+ andYetAnotherReallyLongIdent
/* And no further */
+ reallyLongIdent;
/* Comments can be written like this.
No leading star is required on each line.
Everything will line up just fine.
In this form, include the final closing on the last line. */
let test = 10;
/* You could begin the block bar out like this.
And it still works correctly. */
let test = 10;
/** Include multiple opening stars if you like.
And it will still work. */
let test = 10;
/** This comment will be corrected.
when printed. */
let test = 10;
/** Comments with text on line zero
* Still work well with comments that have stars on the left side.
*/
let test = 10;
/*
* Even though the precedence of the operators are different, no
* "simplification" grouping is needed.
*/
let testPrintingPrecedence =
reallyLongIdent
+ reallyLongIdent
* andYetAnotherReallyLongIdent
+ reallyLongIdent;
let testPrintingPrecedence =
reallyLongIdent
/*
* In this case, grouping of the right expression is needed because the
* right side of the infix operator is of *lower* precedence than STAR.
*/
+ reallyLongIdent
* (
reallyLongIdent
+ andYetAnotherReallyLongIdent
)
+ reallyLongIdent
* 10;
let testPrintingPrecedence =
reallyLongIdent
/*
* In this case, grouping of the right expression is needed because the
* right side of the infix operator is of *lower* precedence than STAR.
*/
+ reallyLongIdent
* (
reallyLongIdent
+ andYetAnotherReallyLongIdent
)
+ reallyLongIdent;
let add = (x, y) => x + y;
let testPrintingPrecedence =
reallyLongIdent
/*
* In this case, grouping of the right expression is needed because the
* right side isn't even infix at all.
*/
+ reallyLongIdent
* add(
reallyLongIdent,
andYetAnotherReallyLongIdent,
)
+ reallyLongIdent;
/*
* Test wrapping every form of named arguments where various parts are
* commented.
*/
let a = 10;
let b = 20;
/*A*/
let named =
/* a::a */
(
~a,
/* b::b */
~b,
) =>
/* a + b */
a + b;
/*B*/
let namedAlias =
/* a::aa */
(
~a as aa,
/* b::bb */
~b as bb,
) =>
/* aa + bb */
aa + bb;
/*C*/
let namedAnnot =
/* ~a a: option(int) */
(
~a: option(int),
/* ~b b: option(int) */
~b: option(int),
) =>
/* 20 */
20;
/*D*/
let namedAliasAnnot =
/* a::(aa: option int) */
(
~a as aa: option(int),
/* b::(bb: option int) */
~b as bb: option(int),
) =>
/* 20 */
20;
/*E*/
let optional =
/* a::a=? */
(
~a=?,
/* b::b=? */
~b=?,
/* () */
(),
) =>
/* 10 */
10;
/*F*/
let optionalAlias =
/* a::aa */
(
~a as aa=?,
/* ?b:bb */
~b as bb=?,
/* () */
(),
) =>
/* 10 */
10;
/*G*/
let optionalAnnot =
/* a::(a: option int)=? */
(
~a: option(int)=?,
/* ?b:(b: option int) */
~b: option(int)=?,
/* () */
(),
) =>
/* 10 */
10;
/*H*/
let optionalAliasAnnot =
/* a::(aa: option int)=? */
(
~a as aa: option(int)=?,
/* b::(bb: option int)=? */
~b as bb: option(int)=?,
/* () = */
(),
) =>
/* 10 */
10;
/*I: This one is really annoying? Where's the visual label?*/
let defOptional =
/* a::a=10 */
(
~a=10,
/* b::b=10 */
~b=10,
/* () = */
(),
) =>
/* 10 */
10;
/*J*/
let defOptionalAlias =
/* a::aa=10 */
(
~a as aa=10,
/* b::bb=10 */
~b as bb=10,
/* () = */
(),
) =>
/* 10; */
10;
/*K*/
let defOptionalAnnot =
/* a::(a:int)=10 */
(
~a: int=10,
/* b::(b:int)=10 */
~b: int=10,
/* () = */
(),
) =>
/* 10; */
10;
/*L*/
let defOptionalAliasAnnot =
/* a::(aa:int)=10 */
(
~a as aa: int=10,
/* b::(bb:int)=10 */
~b as bb: int=10,
/* () = */
(),
) =>
/* 10; */
10;
/* Invoking them */
named(
/* a::a */
~a,
/* b::b; */
~b,
);
named(
/* a::a */
~a,
/* b::b; */
~b,
);
optional(
/* a::a */
~a,
/* b::b; */
~b,
);
optional(
/* a::a */
~a,
/* b::b; */
~b,
);
let explictlyPassed =
/* optional */
optional(
/* a::? */
/* None */
~a=?None,
/* b::? */
/* None; */
~b=?None,
);
let a = None;
let explictlyPassed =
/* optional */
optional(
/* a::? */
~a?,
/* b::? */
/* None; */
~b=?None,
);
let complex_default =
(~callback=(k, d) => 4, x) => 3;
let myList = /*CommentAfterEqualBeforeList */ [
1,
2,
3,
];
let myList = [
/*CommentAfterEqualBefore1 */ 1,
2,
3,
];
let myList = [
1 /*CommentAfterOneBeforeCons */,
2,
3,
];
let myList = [
1,
2 /*CommentAfterTwoBeforeCons */,
3,
];
let myList = [
1,
2,
/*CommentAfterConsBeforeThree */ 3,
];
let myList = [
1,
2,
3 /*CommentAfterThreeBeforeCons*/,
];
let myList = [
1,
2,
3 /*same w space after three */,
];
let myList = [
1,
2,
3 /*same w space before rbracket*/,
];
let myList = [
1,
2,
3 /*same w both */,
];
/* End of line comments */
let myList = [
1,
2,
3 /*no space after three */
];
let myList = [
1,
2,
3 /*same w space after three */
];
let myList = [
1,
2, /*no space after two comma */
3,
];
let myList = [
1,
2, /*same w space after two comma */
3,
];
/* End of line comments */
let myList = [
1,
2, /*no space after two comma */
3,
];
let myList = [
1,
2, /*same w space after two comma */
3,
];
let myRec = {
x: 1,
y: 2, /*no space after two */
z: 3,
};
let myRec = {
x: 1,
y: 2, /*same w space after two */
z: 3,
};
/* Ensure end of line comments force breaks */
let myList = [
1,
2,
3 /* */
];
let myList = [1, 2, /**/ 3];
let myList = [
1,
2,
3 /*CommentAfterConsBeforeAppendedTo */,
...myList,
];
let myList = [3, 4, 5];
let simpleListPattern = x =>
switch (x) {
| [1, 2, 3] => 0
| _ => 0
};
type blahType = string;
let x: blahType = "asdf";
type nameAge = {
age: int,
name: string,
};
type hasABunch = {
/*
* Field comment
*/
fieldOne: int,
fieldtwo: list(int),
fieldThree: list(string),
fieldFour: nameAge,
/* Comment at bottom of record type def */
};
type functionsInARecord = {
adder: int => int,
minuser: int => int,
};
let myFunctionsInARecord = {
adder: x => x,
minuser: x => x,
};
let myFunctionsInARecordThatMustWrap = {
/* Desired wrapping */
adder: reallyLongArgument => reallyLongArgument,
minuser: anotherReallyLongArgument => anotherReallyLongArgument,
/* Comment at bottom of record */
};
type twoArgFunctionsInARecord = {
adder: (int, int) => int,
minuser: (int, int) => int,
};
let myFunctionsInARecordThatMustWrap = {
/* Desired wrapping */
adder:
(
reallyLongArgument,
anotherReallyLongArgument,
) => reallyLongArgument,
minuser:
(
reallyLongArgument,
anotherReallyLongArgument,
) =>
reallyLongArgument
+ anotherReallyLongArgument,
};
type threeArgFunctionsInARecord = {
adder: (int, int, int) => int,
minuser: (int, int, int) => int,
};
let myFunctionsInARecordThatMustWrap = {
/* Desired wrapping */
adder:
/* Even if you have a comment before fun */
(
reallyLongArgument,
/* Or before the first arg */
anotherReallyLongArgument,
yetAnotherReallyLongArgument,
) => reallyLongArgument,
minuser:
(
reallyLongArgument,
anotherReallyLongArgument,
anotherReallyLongArgument,
) =>
reallyLongArgument
+ anotherReallyLongArgument,
};
let oneArgShouldWrapToAlignWith =
theFunctionNameBinding => theFunctionNameBinding;
let twoArgsShouldWrapToAlignWith =
(firstArgHere, secondArgThere) => secondArgThere;
let rec oneArgShouldWrapToAlignWith =
theFunctionNameBinding => theFunctionNameBinding;
let rec twoArgsShouldWrapToAlignWith =
(firstArgHere, secondArgThere) => secondArgThere;
let secondArgShouldWrap =
(pointLess, (a, b, c, d, e, f, g, h)) =>
pointLess + a + b + c + d + e;
/* Now check that one and two args both indent the same when applying */
let reallyReallyLongVarName = "hello";
let result =
oneArgShouldWrapToAlignWith(
reallyReallyLongVarName,
);
let result =
twoArgsShouldWrapToAlignWith(
reallyReallyLongVarName,
reallyReallyLongVarName,
);
let justReturn = x => x;
/* With default formatting settings: Two arguments are special cased in
function application "justReturn hasABunch" */
let acceptsTwoThings =
(nameAge: nameAge, hasABunch: hasABunch) =>
justReturn(hasABunch);
/*
Ideally, we'd allow "acceptsTwoThings {age, name}" on the first line, then
wrapping the final argument across multiple, but that is difficult to tell
the formatter "if the final argument cannot fit", but everything else can,
then only wrap the final argument with open faced braces. It's possible, but
not a v1 feature of wrapping.
*/
let result =
acceptsTwoThings(
{
age: 20,
name: "a",
},
{
fieldOne: 10,
fieldtwo: [10, 20],
fieldThree: ["one", "two"],
fieldFour: {
age: 20,
name: "joe",
},
},
);
let howDoesInfixOperatorsWrapWhenYouMustWrapQuestionMark =
(x, y, z) =>
x + y + z;
let howDoesInfixOperatorsWrapWhenYouMustWrapQuestionMark =
(x, y) =>
x + y;
let reallyHowDoesInfixOperatorsWrapWhenYouMustWrapQuestionMark =
(x, y, z) =>
x + y + z;
let reallyHowDoesInfixOperatorsWrapWhenYouMustWrapQuestionMark =
(x, y) =>
x + y;
let reallyLongFunctionNameThatJustConcats = a =>
String.concat("-", a);
let seeHowLongValuesWrap = {
age: 30,
name:
reallyLongFunctionNameThatJustConcats([
"one",
"two",
"two",
"two",
"two",
"two",
"two",
]),
};
/*
/--Everything up to the arrow is label left--\ /-The return is label right-\
/-append => to last-\
/-----------------------\ /--------------------\ */
let onlyReturnWraps = ((a, b, c, d, e, f)) => (
a,
b,
c,
d,
e,
f,
);
let bothArgsWrapAndIndent =
((a, b, c, d, e, f), (h, i, j, k, l, m)) => (
a,
b,
c,
d,
e,
f,
);
let result =
onlyReturnWraps((10, 11, 12, 13, 14, 15));
let result =
bothArgsWrapAndIndent(
(10, 11, 12, 13, 14, 15),
(10, 11, 12, 13, 14, 15),
);
type sixteenTuple = (
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
);
/* Nothing annotated */
let echoTuple =
(
(
a,
b,
c,
d,
e,
f,
g,
h,
i,
j,
k,
l,
m,
n,
o,
p,
),
) => (
a,
b,
c,
d,
e,
f,
g,
h,
i,
j,
k,
l,
m,
n,
o,
p,
);
/* Nothing annotated fun */
let echoTuple =
(
(
a,
b,
c,
d,
e,
f,
g,
h,
i,
j,
k,
l,
m,
n,
o,
p,
),
) => (
a,
b,
c,
d,
e,
f,
g,
h,
i,
j,
k,
l,
m,
n,
o,
p,
);
let echoTheEchoer =
(x: sixteenTuple => sixteenTuple)
: (sixteenTuple => sixteenTuple) => x;
/* Nothing annotated fun, passed to func */
echoTheEchoer(
(
(
a,
b,
c,
d,
e,
f,
g,
h,
i,
j,
k,
l,
m,
n,
o,
p,
),
) =>
(
a,
b,
c,
d,
e,
f,
g,
h,
i,
j,
k,
l,
m,
n,
o,
p,
)
);
/* Argument annotated */
let echoTuple =
(
(
a,
b,
c,
d,
e,
f,
g,
h,
i,
j,
k,
l,
m,
n,
o,
p,
): sixteenTuple,
) => (
a,
b,
c,
d,
e,
f,
g,
h,
i,
j,
k,
l,
m,
n,
o,
p,
);
/* Argument annotated fun */
let echoTuple =
(
(
a,
b,
c,
d,
e,
f,
g,
h,
i,
j,
k,
l,
m,
n,
o,
p,
): sixteenTuple,
) => (
a,
b,
c,
d,
e,
f,
g,
h,
i,
j,
k,
l,
m,
n,
o,
p,
);
/* Argument annotated, return type annotated */
let echoTuple =
(
(
a,
b,
c,
d,
e,
f,
g,
h,
i,
j,
k,
l,
m,
n,
o,
p,
): sixteenTuple,
)
: sixteenTuple => (
a,
b,
c,
d,
e,
f,
g,
h,
i,
j,
k,
l,
m,
n,
o,
p,
);
/* Desired formatting if first line fits within margin */
let makeTuple =
(
a,
b,
c,
d,
e,
f,
g,
h,
i,
j,
k,
l,
m,
n,
o,
p,
) => (
a,
b,
c,
d,
e,
f,
g,
h,
i,
j,
k,
l,
m,
n,
o,
p,
);
/* Desired formatting if first line fits within margin (70) */
let (
a,
b,
c,
d,
e,
f,
g,
h,
i,
j,
k,
l,
m,
n,
o,
p,
) =
makeTuple(
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
);
/* Annotated version */
let (
a,
b,
c,
d,
e,
f,
g,
h,
i,
j,
k,
l,
m,
n,
o,
p,
): sixteenTuple =
makeTuple(
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
);
/* Annotated inline */
let x: (
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
) =
makeTuple(
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
);
let (
a,
b,
c,
d,
e,
f,
g,
h,
i,
j,
k,
l,
m,
n,
o,
p,
) =
echoTuple((
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
));
/* Annotated version */
let (
a,
b,
c,
d,
e,
f,
g,
h,
i,
j,
k,
l,
m,
n,
o,
p,
): sixteenTuple =
echoTuple((
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
));
/* Annotated inline */
let x: (
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
) =
echoTuple((
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
));
/* Desired formatting if pattern does not fit, arguments do (margin 70) */
/* Destructured */
let (
axx,
bxx,
cxx,
dxx,
exx,
fxx,
gxx,
hxx,
ixx,
jxx,
kxx,
lxx,
mxx,
nxx,
oxx,
pxx,
) =
makeTuple(
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
);
/* Annotated */
/* Destructured */
let (
axx,
bxx,
cxx,
dxx,
exx,
fxx,
gxx,
hxx,
ixx,
jxx,
kxx,
lxx,
mxx,
nxx,
oxx,
pxx,
): sixteenTuple =
makeTuple(
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
);
/* Annotated */
/* Destructured */
/* Inline */
let (
axx,
bxx,
cxx,
dxx,
exx,
fxx,
gxx,
hxx,
ixx,
jxx,
kxx,
lxx,
mxx,
nxx,
oxx,
pxx,
): (
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
) =
makeTuple(
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
);
/* Not-Destructured */
let someResult =
makeTuple(
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
);
/* Annotated */
/* Not-Destructured */
let someResult: sixteenTuple =
makeTuple(
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
);
/* Annotated */
/* Not-Destructured */
/* Inline */
let someResult: (
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
) =
makeTuple(
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
);
/* Destructured */
let (
axx,
bxx,
cxx,
dxx,
exx,
fxx,
gxx,
hxx,
ixx,
jxx,
kxx,
lxx,
mxx,
nxx,
oxx,
pxx,
) =
echoTuple((
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
));
/* Annotated */
let (
axx,
bxx,
cxx,
dxx,
exx,
fxx,
gxx,
hxx,
ixx,
jxx,
kxx,
lxx,
mxx,
nxx,
oxx,
pxx,
): sixteenTuple =
echoTuple((
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
));
/* Annotated Inline */
let (
axx,
bxx,
cxx,
dxx,
exx,
fxx,
gxx,
hxx,
ixx,
jxx,
kxx,
lxx,
mxx,
nxx,
oxx,
pxx,
): (
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
) =
echoTuple((
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
));
/* Not-Destructured */
let someResult =
echoTuple((
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
));
/* Annotated */
/* Not-Destructured */
let someResult: sixteenTuple =
echoTuple((
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
));
/* Annotated Inline */
/* Not-Destructured */
let someResult: (
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
) =
echoTuple((
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
));
/* Desired formatting if neither fit on one line (margin 70) */
/* Destructured */
let (
axx,
bxx,
cxx,
dxx,
exx,
fxx,
gxx,
hxx,
ixx,
jxx,
kxx,
lxx,
mxx,
nxx,
oxx,
pxx,
) =
makeTuple(
axx,
bxx,
cxx,
dxx,
exx,
fxx,
gxx,
hxx,
ixx,
jxx,
kxx,
lxx,
mxx,
nxx,
oxx,
pxx,
);
/* Annoted */
let (
axx,
bxx,
cxx,
dxx,
exx,
fxx,
gxx,
hxx,
ixx,
jxx,
kxx,
lxx,
mxx,
nxx,
oxx,
pxx,
): sixteenTuple =
makeTuple(
axx,
bxx,
cxx,
dxx,
exx,
fxx,
gxx,
hxx,
ixx,
jxx,
kxx,
lxx,
mxx,
nxx,
oxx,
pxx,
);
/* Annoted inline */
let (
axx,
bxx,
cxx,
dxx,
exx,
fxx,
gxx,
hxx,
ixx,
jxx,
kxx,
lxx,
mxx,
nxx,
oxx,
pxx,
): (
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
) =
makeTuple(
axx,
bxx,
cxx,
dxx,
exx,
fxx,
gxx,
hxx,
ixx,
jxx,
kxx,
lxx,
mxx,
nxx,
oxx,
pxx,
);
/* Not-Destructured */
let someResult =
makeTuple(
axx,
bxx,
cxx,
dxx,
exx,
fxx,
gxx,
hxx,
ixx,
jxx,
kxx,
lxx,
mxx,
nxx,
oxx,
pxx,
);
/* Not-Destructured */
/* Annoted */
let someResult: sixteenTuple =
makeTuple(
axx,
bxx,
cxx,
dxx,
exx,
fxx,
gxx,
hxx,
ixx,
jxx,
kxx,
lxx,
mxx,
nxx,
oxx,
pxx,
);
/* Not-Destructured */
/* Annoted inline */
let someResult: (
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
) =
makeTuple(
axx,
bxx,
cxx,
dxx,
exx,
fxx,
gxx,
hxx,
ixx,
jxx,
kxx,
lxx,
mxx,
nxx,
oxx,
pxx,
);
/* Desired formatting if neither fit on one line (margin 70) */
/* Destructured */
let (
axx,
bxx,
cxx,
dxx,
exx,
fxx,
gxx,
hxx,
ixx,
jxx,
kxx,
lxx,
mxx,
nxx,
oxx,
pxx,
) =
echoTuple((
1000,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
));
/* Annoted */
/* Destructured */
let (
axx,
bxx,
cxx,
dxx,
exx,
fxx,
gxx,
hxx,
ixx,
jxx,
kxx,
lxx,
mxx,
nxx,
oxx,
pxx,
): sixteenTuple =
echoTuple((
1000,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
));
/* Annoted Inline */
/* Destructured */
let (
axx,
bxx,
cxx,
dxx,
exx,
fxx,
gxx,
hxx,
ixx,
jxx,
kxx,
lxx,
mxx,
nxx,
oxx,
pxx,
): (
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
) =
echoTuple((
1000,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
));
/* Desired formatting if neither fit on one line (margin 70) */
/* Not-Destructured */
let someResult =
echoTuple((
1000,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
));
/* Annoted */
/* Not-Destructured */
let someResult: sixteenTuple =
echoTuple((
1000,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
));
/* Annoted Inline */
/* Not-Destructured */
let someResult: (
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
) =
echoTuple((
1000,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
10,
));
/* The rhs of = shouldn't be broken onto its own newline: @see ensureSingleTokenSticksToLabel */
let someResult: (
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
int,
) = someResult;
type sevenStrings = (
string,
string,
string,
string,
string,
string,
string,
);
let (only, the, type_, should, have, to_, wrap) = (
"only",
"the",
"type",
"should",
"have",
"to",
"wrap",
);
let (only, the, type_, should, have, to_, wrap): sevenStrings = (
"only",
"the",
"type",
"should",
"have",
"to",
"wrap",
);
let ifTheNameIsReallyLongTheTypeAndValueShouldBothWrap: (
string,
string,
string,
string,
string,
string,
string,
) = (
"only",
"the",
"type",
"should",
"have",
"to",
"wrap",
);
let (
the,
type_,
and_,
value,
should,
both,
wrap,
): (
string,
string,
string,
string,
string,
string,
string,
) = (
"but",
"the",
"destructured",
"assignment",
"should",
"not",
"wrap",
);
let myPolyFunc: 'a. 'a => 'a = o => o;
let myNonPolyFunc: 'a => 'a = o => o;
let locallyAbstractFunc = (type a, input: a) => input;
let locallyAbstractFuncNotSugared =
(type a, input: a) => input;
let locallyAbstractFuncAnnotated: type a. a => a =
(type a, input: a) => input;
/*
Examples of how long versions of these should be wrapped: df stands for
"desired formatting" when the function binding itself must wrap.
*/
let df_myPolyFunc: 'a. 'a => 'a = o => o;
let df_myNonPolyFunc: 'a => 'a = o => o;
type nameBlahType = {nameBlah: int};
let myFunc = (~firstArg, ~another, ~fl) => {
nameBlah: 10,
};
type inputEchoRecord('a) = {inputIs: 'a};
let df_locallyAbstractFunc =
(type a, type b, input: a) => {
inputIs: input,
}; /* With setting ReturnValOnSameLine */
let df_locallyAbstractFuncNotSugared =
(type a, type b, input: a) => {
inputIs: input,
};
/**
* The following is automatically expanded at the parser level into:
*
* let df_locallyAbstractFuncAnnotated:
* 'a .
* 'a => 'a => inputEchoRecord 'a
* =
* fun (type a) => (
* fun (input: a) (input: a) => {inputIs: input}:
* a => a => inputEchoRecord a
* );
*
*/
let df_locallyAbstractFuncAnnotated
: type a. (a, a) => inputEchoRecord(a) =
(input: a, input: a) => {
inputIs: input,
};
/**
* The following is automatically expanded at the parser level into:
*
* let df_locallyAbstractFuncAnnotated:
* 'a .
* 'a => 'a => inputEchoRecord 'a
* =
* fun (type a) => (
* df_locallyAbstractFuncAnnotated:
* a => a => inputEchoRecord a
* );
*
*/
let df_locallyAbstractFuncAnnotatedRef:
type a. (a, a) => inputEchoRecord(a) = df_locallyAbstractFuncAnnotated;
/**
* Doesn't do what you want:
*
* let df_locallyAbstractFuncAnnotatedExtra: type a. a => a => inputEchoRecord a =
* fun (type a)
* (input:a)
* (input:a) => {
* inputIs: input
* };
*/
/**
* The following is automatically expanded at the parser level into:
*
* let df_locallyAbstractFuncAnnotatedTwo:
* 'a 'b .
* 'a => 'b => (inputEchoRecord 'a, inputEchoRecord 'b)
* =
* fun (type a) (type b) => (
* fun (input: a) (input2: b) => ({inputIs: input}, {inputIs:input2}):
* a => b => (inputEchoRecord a, inputEchoRecord b)
* );
*
*/
let df_locallyAbstractFuncAnnotated
: type a b.
(a, b) =>
(
inputEchoRecord(a),
inputEchoRecord(b),
) =
(input: a, input2: b) => (
{ inputIs: input },
{ inputIs: input2 },
);
/**
* This case shows why inferring what was originally sugar type a b . blahblah
* is not so trivial. We have to take the last Pexp_constraint type, varify the
* constructors, then check if the result is equal to the first
* Ppat_constraint. In this case, they're not equal!
*/
let df_locallyAbstractFuncAnnotated
: 'figureMeOut =
(type a, type b)
: (
(a, b) =>
(
inputEchoRecord(a),
inputEchoRecord(b),
)
) =>
(input: a, input2: b) => (
{ inputIs: input },
{ inputIs: input2 },
);
let createTuple_thisFuncShouldWrapCorrectlyNow
: 'a. ('a, 'a, 'a) => ('a, 'a, 'a) =
(someVar, someVar2, someVar3) => (
someVar,
someVar2,
someVar3,
);
let (theTupleTypeAnnotationShouldWrap: (
string,
string,
string,
string,
)) = (
"now these tuple values should wrap",
"now these tuple values should wrap",
"now these tuple values should wrap",
"now these tuple values should wrap",
);
let rec mutuallyRecursiveOne = x =>
mutuallyRecursiveTwo(x + x)
and mutuallyRecursiveTwo = y => print_int(y);
/* The only downside to this is that now you can't redeclare a binding. */
/* let newMutualRecursionSyntax x => newMutuallyRecursiveTwo (x + x); */
/* let newMutuallyRecursiveTwo y => print_int y; */
/* */
type x = pri int;
type y = x = ..;
type myType('a, 'b, 'c) = pri ('a, 'b, 'c);
type privateVariant =
pri | BigSize(int) | SmallSize(int);
type doubleEqualsDoublePrivateVariant =
privateVariant =
pri | BigSize(int) | SmallSize(int);
type myRecordWithReallyLongName = {
xx: int,
yy: int,
};
type doubleEqualsRecord =
myRecordWithReallyLongName = {
xx: int,
yy: int,
};
type doubleEqualsDoublePrivateRecord =
myRecordWithReallyLongName =
pri {
xx: int,
yy: int,
};
type someConstructor =
| SomeConstructorHi(int, int);
type someRecord = {
firstFieldInRecord: int,
secondField: int,
};
/*
With settings.functionBindingStyle = AttachFirstTermToLabelIffTwoTotalTerms,
the binding name becomes part of the label when there are only two total
terms in the binding/argument pattern list (the name, followed by one
pattern).
*/
let funcOnSomeConstructorHi =
(SomeConstructorHi(x, y)) =>
x + y;
let funcOnSomeConstructorHi =
(SomeConstructorHi(x, y), secondArg) =>
x + y;
/* With two args */
let funcOnSomeRecord =
({ firstFieldInRecord, secondField }) =>
firstFieldInRecord + secondField;
let funcOnSomeRecord =
(
{ firstFieldInRecord, secondField },
secondArg,
) =>
firstFieldInRecord + secondField;
/*
With settings.functionBindingStyle = DontAttachFirstTermToLabel,
the binding name becomes part of the label when there are only two total
terms in the binding/argument pattern list (the name, followed by one
pattern).
*/
let funcOnSomeConstructorHi =
(SomeConstructorHi(x, y)) =>
x + y;
let funcOnSomeRecord =
({ firstFieldInRecord, secondField }) =>
firstFieldInRecord + secondField;
/* With two args */
let funcOnSomeConstructorHi =
(SomeConstructorHi(x, y), secondArg) =>
x + y;
let funcOnSomeRecord =
(
{ firstFieldInRecord, secondField },
secondArg,
) =>
firstFieldInRecord + secondField;
type simpleTupleVariant =
| SimpleActuallyATuple((int, int));
let returnTheSimpleTupleVariant = i =>
SimpleActuallyATuple(i, i);
let shouldWrapLike = whenLongArg =>
SimpleActuallyATuple(
whenLongArg,
whenLongArg,
);
type recordWithLong = {
someField: int,
anotherField: string,
};
/*
* Commenting first of two mutualy recursive types.
*/
type recursiveType =
/* First variant of first mutually recursive */
| Blah
/* Second variant of first mutually recursive */
| Another(option(anotherRecursiveType))
/*
* Commenting second of two mutually recursive types.
*/
and anotherRecursiveType =
/* Second variant of second mutually recursive */
| Baz
/* Second variant of second mutually recursive */
| Recursive(option(recursiveType));
/**
* Commented GADT definition.
*/
type term(_) =
/* First variant leaf of GADT */
| Int /*first var arg */(int)
: /* First GADT res */ term(int)
/* Second variant leaf of GADT */
| Float /*second var arg */(int)
: /* Second GADT res */ term(int)
/* Third variant leaf of GADT */
| Bool /*third var arg */(int)
: /* Third GADT res */ term(int);
/* Commented colors */
type commentedTypeDef =
/*
* Commenting first variant member.
*/
| First(
(
/* First field of tuple in first variant member */
int,
/* Second field of tuple in first variant member */
int,
),
)
/*
* Commenting second variant member.
*/
| Second(int)
/*
* Commenting third variant member.
*/
| Third(
list
/* Commenting deep in type def */
(list(int)),
);
type colors =
| Red(int)
| Black(int)
| Green(int);
let blah = arg =>
switch (arg) {
/* Comment before Bar */
| /* Comment between bar/pattern */ Red(_) => 1
/* Comment Before non-first bar */
| /* Comment betwen bar/pattern */ Black(_) => 0
| Green(_) => 0
};
let blah =
fun
| Red(_) => 1
| Black(_) => 0
| Green(_) => 1;
let blahCurriedX = x =>
fun
/* Comment before first bar */
/* Comment between first bar and OR pattern */
| Red(x)
| Black(x)
| Green(x) => 1
/* Comment before second bar */
| Black(x) => 0
| Green(x) => 0;
type reallyLongVariantNames =
| ReallyLongVariantName(recordWithLong)
| AnotherReallyLongVariantName(int, int, int)
| AnotherReallyLongVariantName2(
int,
int,
int,
);
let howDoLongMultiBarPatternsWrap = x =>
switch (x) {
| AnotherReallyLongVariantName(_, _, _) => 0
| AnotherReallyLongVariantName2(_, _, _) => 0
| ReallyLongVariantName({
someField,
anotherField,
}) => 0
};
let letsCombineTwoLongPatternsIntoOneCase = x =>
switch (x) {
| AnotherReallyLongVariantName(_, _, _)
| AnotherReallyLongVariantName2(_, _, _) => 0
| ReallyLongVariantName({
someField,
anotherField,
}) => 0
};
let letsPutAWhereClauseOnTheFirstTwo = x =>
switch (x) {
| AnotherReallyLongVariantName(_, _, _)
| AnotherReallyLongVariantName2(_, _, _)
when true => 0
| ReallyLongVariantName({
someField,
anotherField,
}) => 0
};
let letsPutAWhereClauseOnTheLast = x =>
switch (x) {
| AnotherReallyLongVariantName(_, _, _)
| AnotherReallyLongVariantName2(_, _, _) => 0
| ReallyLongVariantName({
someField,
anotherField,
})
when true => 0
};
type wrappingGadt(_) =
| ThisIsLongSoTypeWillWrap(int)
: wrappingGadt(int)
| Add: wrappingGadt((int, int) => int)
| App(
wrappingGadt('b => 'a),
wrappingGadt('b),
)
: wrappingGadt('a);
type withThreeFields = {
name: string,
age: int,
occupation: string,
};
let testRecord = {
name: "joe",
age: 20,
occupation: "engineer",
};
let anotherRecord = {
...testRecord,
name: "joe++",
age: testRecord.age + 10,
};
type polymorphicCommentedType
/* Commenting the first type variable */
(
'a,
/* Commenting the second type variable */
'b,
) =
list('a, 'b);
/**
* Commenting the entire record definition.
*/
type withThreeFieldsCommented = {
/* Commenting the first field */
nameCommented: string,
/* Commenting the second field */
ageCommented: int,
/* Commenting the third field */
occupationCommented: string,
};
/**
* Commenting the entire record.
*/
let testRecordCommented = {
/* Commenting the first field */
nameCommented: "joe",
/* Commenting the second field */
ageCommented: 20,
/* Commenting the last field */
occupationCommented: "engineer",
};
/*
* Test comments near the arguments.
*/
let callMeWithComments =
/* Comment before first arg "a" */
(
a: int,
/* Comment before second arg "b" */
b: int,
)
/* Comment before return type annotation "int" */
: int =>
/* Comment above return value a + b + c */
a + b + c;
let callMeWithComments2 =
/* Comment before the only argument */
(
(
a: int,
/* Comment before second arg "b" */
b: int,
),
)
/* Comment before return type annotation "int" */
: int =>
/* Comment above return value a + b + c */
a + b + c;
let result =
/* Comment before function to invoke */
callMeWithComments(
/* Comment before first argument expression */
1 + 2 + 3 + 3,
/* Comment before second argument expression */
1 + 2 + 3 + 3,
);
module type ASig = {
let a: int;
};
module type BSig = {
let b: int;
};
module AMod = {
let a = 10;
};
module BMod = {
let b = 10;
};
module CurriedSugar =
/* Commenting before First curried functor arg */
/* If these comments aren't formatted correctly
* see how functor args' locations aren't set
* correclty due to the fold_left.
*/
(
A: ASig,
/* Commenting before Second curried functor arg */
B: BSig,
) => {
let result = A.a + B.b;
/* Comment at bottom of module expression */
};
module CurriedSugarFunctorResult =
/* Commenting before functor name*/
CurriedSugar
/* Commenting before functor arg 1 in app */
(
AMod,
/* Commenting before functor arg 2 in app */
BMod,
);
module CurriedSugarFunctorResultInline =
/* Commenting before functor name*/
CurriedSugar
/* Commenting before functor arg 1 in app */
(
{
let a = 10;
},
{
/* Commenting before functor arg 2 in app */
let b = 10;
},
);
module type FunctorType =
(ASig, ASig, BSig) => BSig;
/*
* Commenting locations
*/
let commentingBeforeEqual /*beforeEqual*/ = {
name: "hello",
age: 20,
occupation: "programmer",
};
let commentingAfterEqual = /*afterEqual*/ {
name: "hello",
age: 20,
occupation: "programmer",
};
let commentingBeforeEqualBeforeType /*beforeEqualBeforeType*/: withThreeFields = {
name: "hello",
age: 20,
occupation: "programmer",
};
let commentingBeforeEqualAfterType:
withThreeFields /*beforeEqualAfterType*/ = {
name: "hello",
age: 20,
occupation: "programmer",
};
let commentingAfterEqualAfterType: withThreeFields = /*afterEqual*/ {
name: "hello",
age: 20,
occupation: "programmer",
};
let /*beforePattern*/ commentingBeforePattern: withThreeFields = {
name: "hello",
age: 20,
occupation: "programmer",
};
/*beforePattern*/
let /*beforePattern2 */ commentingBeforePattern2: withThreeFields = {
name: "hello",
age: 20,
occupation: "programmer",
};
/*beforePattern*/
let /*beforePattern2 */ commentingBeforePatternSpecial: withThreeFields = {
name: "hello",
age: 20,
occupation: "programmer",
};
let produceRecord /*commentBeforeArg*/ = x => {
name: "hello",
age: 20,
occupation: "programmer",
};
let produceRecord = x => /*commentAfterArg*/ {
name: "hello",
age: 20,
occupation: "programmer",
};
let myPolyFuncCommentBeforeColon /*beforeColon */
: 'a. 'a => 'a =
o => o;
let myPolyFuncCommentAfterColon: 'a. 'a => 'a = /*afterColon */
o => o;
let myPolyFuncCommentBeforeArrow: 'a. 'a => 'a = /*beforeArrow */
o => o;
let myPolyFuncCommentAfterArrow
: 'a. 'a => /*afterArrow */ 'a =
o => o;
/* THIS IS THE ONLY TEST THAT IS FAILING DUE TO BEING NON-IDEMPOTENT */
/* let myPolyFuncCommentBeforeEqual : 'a . ('a) => 'a /*beforeEqual */ = fun(o) => o; */
let myPolyFuncCommentAfterEqual: 'a. 'a => 'a = /*afterEqual */
o => o;
let myNonPolyFuncCommentBeforeColon /*BeforeColon */
: 'a => 'a =
o => o;
let myNonPolyFuncCommentAfterColon
: /*AfterColon */ 'a => 'a =
o => o;
let myNonPolyFuncCommentBeforeArrow
: 'a /*BeforeArrow */ => 'a =
o => o;
let myNonPolyFuncCommentAfterArrow
: 'a => /*AfterArrow */ 'a =
o => o;
let myNonPolyFuncCommentBeforeEqual
: 'a => 'a /*BeforeEqual */ =
o => o;
let myNonPolyFuncCommentAfterEqual: 'a => 'a = /*AfterEqual */
o => o;
let lATCurrySugarCommentBeforeType /*BeforeType */ =
(type a, input: a) => input;
let lATCurrySugarCommentAfterType /*AfterType */ =
(type a, input: a) => input;
let lATCurrySugarCommentBeforeArg =
(type a, /*BeforeArg */ input: a) => input;
let lATCurrySugarCommentAfterArg =
(type a, input: a) =>
/*AfterArg */
input;
let lATCurrySugarCommentAfterArrow =
(type a, input: a) => /*AfterArrow */ input;
let lATNotSugaredCommentBeforeEqual /*BeforeEqual*/ =
(type a, input: a) => input;
let lATNotSugaredCommentAfterEqual = /*AfterEqual*/
(type a, input: a) => input;
let lATNotSugaredCommentBeforeType = /*BeforeType*/
(type a, input: a) => input;
let lATNotSugaredCommentAfterType = /*AfterType*/
(type a, input: a) => input;
let lATNotSugaredCommentBeforeArg =
(type a, /*BeforeArg*/ input: a) => input;
let lATNotSugaredCommentAfterArg =
(type a, input: a) =>
/*AfterArg*/
input;
let lATNotSugaredCommentAfterArrow =
(type a, input: a) => /*AfterArrow*/ input;
let lAtFuncAnnotatedCommentBeforeColon /*BeforeColon*/
: type a. a => a =
(type a, input: a) => input;
let lAtFuncAnnotatedCommentAfterColon
/*AfterColon*/
: type a. a => a =
(type a, input: a) => input;
let lAtFuncAnnotatedCommentBeforeTypeVar
/*BeforeTypeVar*/
: type a. a => a =
(type a, input: a) => input;
let lAtFuncAnnotatedCommentAfterTypeVar
/*AfterTypeVar*/
: type a. a => a =
(type a, input: a) => input;
let lAtFuncAnnotatedBeforeEqual
: type a. a => a /*BeforeEqual*/ =
(type a, input: a) => input;
let lAtFuncAnnotatedAfterEqual: type a. a => a = /*AfterEqual*/
(type a, input: a) => input;
/* Ternary wrapping comments */
let ternaryResult =
/* Before Test */
something
/* Before ifTrue */
? callThisFunction(withThisArg)
/* Before ifFalse */
: thatResult;
let ternaryResult =
/* Before Test */
something
/* Before ifTrue */
? callThisFunction(withThisArg)
/* Before ifFalse */
: trailingTest
? /* before nested ifTrue */ true
: /* before nested ifFalse */ false;
let returningATernary = (x, y) =>
x > y ? "hi" : "by";
/** Testing some special comment alignment features */
/* Comments can be written like this.
No leading star is required on each line.
Everything will line up just fine.
In this form, include the final closing on the last line. */
let test = 10;
let test =
/* And if the entire block needs to be re-indented
such as this case, everything will still look okay. */
10;
/* You could begin the block bar out like this.
And it still works correctly. */
let test = 10;
/** Include multiple opening stars if you like.
And it will still work. */
let test = 10;
/** This comment will be corrected.
when printed. */
let test = 10;
/** Comments with text on line zero
* Still work well with comments that have stars on the left side.
*/
let test = 10;
let test =
/* This kind of comment doesn't exactly render well though.
Not many people write comments like this.
*/
10;
let x =
calWith(
reallyLongName,
reallyReallyLongName,
reallyReallyLongName,
reallyReallyLongName,
reallyReallyLongName,
reallyReallyLongName,
a,
a,
a,
alskdjfalskdjfalsdf,
)
+ reallyReallyLongName;
let onlyDoingThisTopLevelLetToBypassTopLevelSequence = {
let x = {
print_int(1);
print_int(20); /* Missing trailing SEMI */
};
let x = {
print_int(1);
print_int(20); /* Ensure missing middle SEMI reported well */
print_int(20);
};
let x = {
print_int(1);
print_int(20);
10;
}; /* Missing final SEMI */
let x = {
print_int(1);
print_int(20);
10;
};
x + x; /* Final item */
};
/* With this unification, anywhere eyou see `= fun` you can just ommit it */
let blah = a => a; /* Done */
let blah = a => a; /* Done (almost) */
let blah = (a, b) => a; /* Done */
let blah = (a, b) => a; /* Done (almost) */
let tryingTheSameInLocalScope = {
let blah = a => a; /* Done */
let blah = a => a; /* Done (almost) */
let blah = (a, b) => a; /* Done */
let blah = (a, b) => a;
(); /* Done (almost) */
};
reallyLongFunctionNameWithArrayThatBreaks([|
"one",
"two",
"two",
"two",
"two",
"two",
"two",
|]);
reallyLongFunctionNameWithRecordStringKeys({
"one": 2345,
"two": 2345678,
"three": 45678,
"four": 45678,
});
fooSpreadES6List([
"sldkjfklsjdflskjdflksjok",
"more tests",
...x,
]);
let { foo: (_: int) } = 2;
================================================
FILE: test/wrapping-rei.t/input.rei
================================================
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
let named : (~a: int, ~b: int) => int;
let namedAlias : (~a: int, ~b: int) => int;
let namedAnnot : (~a: option(int), ~b: option(int)) => int;
let namedAliasAnnot : (~a: option(int), ~b: option(int)) => int;
let optional : (~a: 'a=?, ~b: 'b=?, unit) => int;
let optionalAlias : (~a: 'a=?, ~b: 'b=?, unit) => int;
let optionalAnnot : (~a: int=?, ~b: int=?, unit) => int;
let optionalAliasAnnot : (~a: int=?, ~b: int=?, unit) => int;
let defOptional : (~a: int=?, ~b: int=?, unit) => int;
let defOptionalAlias : (~a: int=?, ~b: int=?, unit) => int;
let defOptionalAnnot : (~a: int=?, ~b: int=?, unit) => int;
let defOptionalAliasAnnot : (~a: int=?, ~b: int=?, unit) => int;
let fun_option_int : (option(int), option(int)) => int;
/* Comments can be written like this.
No leading star is required on each line.
Everything will line up just fine.
In this form, include the final closing on the last line. */
let test: int;
let test:
/* And if the entire block needs to be re-indented
such as this case, everything will still look okay. */
int;
/* You could begin the block bar out like this.
And it still works correctly. */
let test:int;
/** Include multiple opening stars if you like.
And it will still work. */
let test: int;
/** This comment will be corrected.
when printed. */
let test:int;
/** Comments with text on line zero
* Still work well with comments that have stars on the left side.
*/
let test:int;
let test
/* This kind of comment doesn't exactly render well though.
Not many people write comments like this.
*/
:int;
================================================
FILE: test/wrapping-rei.t/run.t
================================================
Format wrapping in .rei files
$ refmt ./input.rei
/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */
let named: (~a: int, ~b: int) => int;
let namedAlias: (~a: int, ~b: int) => int;
let namedAnnot:
(~a: option(int), ~b: option(int)) => int;
let namedAliasAnnot:
(~a: option(int), ~b: option(int)) => int;
let optional: (~a: 'a=?, ~b: 'b=?, unit) => int;
let optionalAlias:
(~a: 'a=?, ~b: 'b=?, unit) => int;
let optionalAnnot:
(~a: int=?, ~b: int=?, unit) => int;
let optionalAliasAnnot:
(~a: int=?, ~b: int=?, unit) => int;
let defOptional:
(~a: int=?, ~b: int=?, unit) => int;
let defOptionalAlias:
(~a: int=?, ~b: int=?, unit) => int;
let defOptionalAnnot:
(~a: int=?, ~b: int=?, unit) => int;
let defOptionalAliasAnnot:
(~a: int=?, ~b: int=?, unit) => int;
let fun_option_int:
(option(int), option(int)) => int;
/* Comments can be written like this.
No leading star is required on each line.
Everything will line up just fine.
In this form, include the final closing on the last line. */
let test: int;
let test:
/* And if the entire block needs to be re-indented
such as this case, everything will still look okay. */
int;
/* You could begin the block bar out like this.
And it still works correctly. */
let test: int;
/** Include multiple opening stars if you like.
And it will still work. */
let test: int;
/** This comment will be corrected.
when printed. */
let test: int;
/** Comments with text on line zero
* Still work well with comments that have stars on the left side.
*/
let test: int;
let test:
/* This kind of comment doesn't exactly render well though.
Not many people write comments like this.
*/
int;